diff options
Diffstat (limited to 'plugins')
93 files changed, 0 insertions, 25224 deletions
diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v deleted file mode 100644 index 4a603f2c52..0000000000 --- a/plugins/btauto/Algebra.v +++ /dev/null @@ -1,591 +0,0 @@ -Require Import Bool PArith DecidableClass Ring Lia. - -Ltac bool := -repeat match goal with -| [ H : ?P && ?Q = true |- _ ] => - apply andb_true_iff in H; destruct H -| |- ?P && ?Q = true => - apply <- andb_true_iff; split -end. - -Arguments decide P /H. - -Hint Extern 5 => progress bool : core. - -Ltac define t x H := -set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. - -Lemma Decidable_sound : forall P (H : Decidable P), - decide P = true -> P. -Proof. -intros P H Hp; apply -> Decidable_spec; assumption. -Qed. - -Lemma Decidable_complete : forall P (H : Decidable P), - P -> decide P = true. -Proof. -intros P H Hp; apply <- Decidable_spec; assumption. -Qed. - -Lemma Decidable_sound_alt : forall P (H : Decidable P), - ~ P -> decide P = false. -Proof. -intros P [wit spec] Hd; destruct wit; simpl; tauto. -Qed. - -Lemma Decidable_complete_alt : forall P (H : Decidable P), - decide P = false -> ~ P. -Proof. - intros P [wit spec] Hd Hc; simpl in *; intuition congruence. -Qed. - -Ltac try_rewrite := -repeat match goal with -| [ H : ?P |- _ ] => rewrite H -end. - -(* We opacify here decide for proofs, and will make it transparent for - reflexive tactics later on. *) - -Global Opaque decide. - -Ltac tac_decide := -match goal with -| [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H -| [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H -| [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D) -| [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D) -| [ |- negb ?b = true ] => apply negb_true_iff -| [ |- negb ?b = false ] => apply negb_false_iff -| [ H : negb ?b = true |- _ ] => apply negb_true_iff in H -| [ H : negb ?b = false |- _ ] => apply negb_false_iff in H -end. - -Ltac try_decide := repeat tac_decide. - -Ltac make_decide P := match goal with -| [ |- context [@decide P ?D] ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ X : context [@decide P ?D] |- _ ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -end. - -Ltac case_decide := match goal with -| [ |- context [@decide ?P ?D] ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ X : context [@decide ?P ?D] |- _ ] => - let b := fresh "b" in - let H := fresh "H" in - define (@decide P D) b H; destruct b; try_decide -| [ |- context [Pos.compare ?x ?y] ] => - destruct (Pos.compare_spec x y); try lia -| [ X : context [Pos.compare ?x ?y] |- _ ] => - destruct (Pos.compare_spec x y); try lia -end. - -Section Definitions. - -(** * Global, inductive definitions. *) - -(** A Horner polynomial is either a constant, or a product P × (i + Q), where i - is a variable. *) - -Inductive poly := -| Cst : bool -> poly -| Poly : poly -> positive -> poly -> poly. - -(* TODO: We should use [positive] instead of [nat] to encode variables, for - efficiency purpose. *) - -Inductive null : poly -> Prop := -| null_intro : null (Cst false). - -(** Polynomials satisfy a uniqueness condition whenever they are valid. A - polynomial [p] satisfies [valid n p] whenever it is well-formed and each of - its variable indices is < [n]. *) - -Inductive valid : positive -> poly -> Prop := -| valid_cst : forall k c, valid k (Cst c) -| valid_poly : forall k p i q, - Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q). - -(** Linear polynomials are valid polynomials in which every variable appears at - most once. *) - -Inductive linear : positive -> poly -> Prop := -| linear_cst : forall k c, linear k (Cst c) -| linear_poly : forall k p i q, Pos.lt i k -> ~ null q -> - linear i p -> linear i q -> linear k (Poly p i q). - -End Definitions. - -Section Computational. - -Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) := - { Decidable_witness := Pos.eqb p q }. -Next Obligation. -apply Pos.eqb_eq. -Qed. - -Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) := - { Decidable_witness := Pos.ltb p q }. -Next Obligation. -apply Pos.ltb_lt. -Qed. - -Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) := - { Decidable_witness := Pos.leb p q }. -Next Obligation. -apply Pos.leb_le. -Qed. - -(** * The core reflexive part. *) - -Hint Constructors valid : core. - -Fixpoint beq_poly pl pr := -match pl with -| Cst cl => - match pr with - | Cst cr => decide (cl = cr) - | Poly _ _ _ => false - end -| Poly pl il ql => - match pr with - | Cst _ => false - | Poly pr ir qr => - decide (il = ir) && beq_poly pl pr && beq_poly ql qr - end -end. - -(* We could do that with [decide equality] but dependency in proofs is heavy *) -Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := { - Decidable_witness := beq_poly p q -}. - -Next Obligation. -split. -revert q; induction p; intros [] ?; simpl in *; bool; try_decide; - f_equal; first [intuition congruence|auto]. -revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition; - try injection Heq; first[congruence|intuition]. -Qed. - -Program Instance Decidable_null : forall p, Decidable (null p) := { - Decidable_witness := match p with Cst false => true | _ => false end -}. -Next Obligation. -split. - destruct p as [[]|]; first [discriminate|constructor]. - inversion 1; trivial. -Qed. - -Definition list_nth {A} p (l : list A) def := - Pos.peano_rect (fun _ => list A -> A) - (fun l => match l with nil => def | cons t l => t end) - (fun _ F l => match l with nil => def | cons t l => F l end) p l. - -Fixpoint eval var (p : poly) := -match p with -| Cst c => c -| Poly p i q => - let vi := list_nth i var false in - xorb (eval var p) (andb vi (eval var q)) -end. - -Fixpoint valid_dec k p := -match p with -| Cst c => true -| Poly p i q => - negb (decide (null q)) && decide (i < k)%positive && - valid_dec i p && valid_dec (Pos.succ i) q -end. - -Program Instance Decidable_valid : forall n p, Decidable (valid n p) := { - Decidable_witness := valid_dec n p -}. -Next Obligation. -split. - revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto. - intros H; induction H; unfold valid_dec in *; bool; try_decide; auto. -Qed. - -(** Basic algebra *) - -(* Addition of polynomials *) - -Fixpoint poly_add pl {struct pl} := -match pl with -| Cst cl => - fix F pr := match pr with - | Cst cr => Cst (xorb cl cr) - | Poly pr ir qr => Poly (F pr) ir qr - end -| Poly pl il ql => - fix F pr {struct pr} := match pr with - | Cst cr => Poly (poly_add pl pr) il ql - | Poly pr ir qr => - match Pos.compare il ir with - | Eq => - let qs := poly_add ql qr in - (* Ensure validity *) - if decide (null qs) then poly_add pl pr - else Poly (poly_add pl pr) il qs - | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql - | Lt => Poly (F pr) ir qr - end - end -end. - -(* Multiply a polynomial by a constant *) - -Fixpoint poly_mul_cst v p := -match p with -| Cst c => Cst (andb c v) -| Poly p i q => - let r := poly_mul_cst v q in - (* Ensure validity *) - if decide (null r) then poly_mul_cst v p - else Poly (poly_mul_cst v p) i r -end. - -(* Multiply a polynomial by a monomial *) - -Fixpoint poly_mul_mon k p := -match p with -| Cst c => - if decide (null p) then p - else Poly (Cst false) k p -| Poly p i q => - if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q) - else Poly (poly_mul_mon k p) i (poly_mul_mon k q) -end. - -(* Multiplication of polynomials *) - -Fixpoint poly_mul pl {struct pl} := -match pl with -| Cst cl => poly_mul_cst cl -| Poly pl il ql => - fun pr => - (* Multiply by a factor *) - let qs := poly_mul ql pr in - (* Ensure validity *) - if decide (null qs) then poly_mul pl pr - else poly_add (poly_mul pl pr) (poly_mul_mon il qs) -end. - -(** Quotienting a polynomial by the relation X_i^2 ~ X_i *) - -(* Remove the multiple occurrences of monomials x_k *) - -Fixpoint reduce_aux k p := -match p with -| Cst c => Cst c -| Poly p i q => - if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q) - else - let qs := reduce_aux i q in - (* Ensure validity *) - if decide (null qs) then (reduce_aux k p) - else Poly (reduce_aux k p) i qs -end. - -(* Rewrite any x_k ^ {n + 1} to x_k *) - -Fixpoint reduce p := -match p with -| Cst c => Cst c -| Poly p i q => - let qs := reduce_aux i q in - (* Ensure validity *) - if decide (null qs) then reduce p - else Poly (reduce p) i qs -end. - -End Computational. - -Section Validity. - -(* Decision procedure of validity *) - -Hint Constructors valid linear : core. - -Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. -Proof. -intros k l p H Hl; induction H; constructor; eauto. -now eapply Pos.lt_le_trans; eassumption. -Qed. - -Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. -Proof. -intros k l p H; revert l; induction H; constructor; eauto; lia. -Qed. - -Lemma linear_valid_incl : forall k p, linear k p -> valid k p. -Proof. -intros k p H; induction H; constructor; auto. -eapply valid_le_compat; eauto; lia. -Qed. - -End Validity. - -Section Evaluation. - -(* Useful simple properties *) - -Lemma eval_null_zero : forall p var, null p -> eval var p = false. -Proof. -intros p var []; reflexivity. -Qed. - -Lemma eval_extensional_eq_compat : forall p var1 var2, - (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p. -Proof. -intros p var1 var2 H; induction p; simpl; try_rewrite; auto. -Qed. - -Lemma eval_suffix_compat : forall k p var1 var2, - (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p -> - eval var1 p = eval var2 p. -Proof. -intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar. -induction Hv; intros var1 var2 Hvar; simpl; [now auto|]. -rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2). - + erewrite (IHHv2 var1 var2); [ring|]. - intros; apply Hvar; lia. - + intros; apply Hvar; lia. -Qed. - -End Evaluation. - -Section Algebra. - -(* Compatibility with evaluation *) - -Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr). -Proof. -intros pl; induction pl; intros pr var; simpl. -+ induction pr; simpl; auto; solve [try_rewrite; ring]. -+ induction pr; simpl; auto; try solve [try_rewrite; simpl; ring]. - destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac]. - try_rewrite; ring_simplify; repeat rewrite xorb_assoc. - match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] => - replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring - end. - rewrite <- IHpl2. - match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring. - simpl; rewrite IHpl1; simpl; ring. -Qed. - -Lemma poly_mul_cst_compat : forall v p var, - eval var (poly_mul_cst v p) = andb v (eval var p). -Proof. -intros v p; induction p; intros var; simpl; [ring|]. -case_decide; simpl; try_rewrite; [ring_simplify|ring]. -replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring. -rewrite <- IHp2; inversion H; simpl; ring. -Qed. - -Lemma poly_mul_mon_compat : forall i p var, - eval var (poly_mul_mon i p) = (list_nth i var false && eval var p). -Proof. -intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring. -inversion H; ring. -match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. -match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end. -Qed. - -Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr). -Proof. -intros pl; induction pl; intros pr var; simpl. - apply poly_mul_cst_compat. - case_decide; simpl. - rewrite IHpl1; ring_simplify. - replace (eval var pr && list_nth p var false && eval var pl2) - with (list_nth p var false && (eval var pl2 && eval var pr)) by ring. - now rewrite <- IHpl2; inversion H; simpl; ring. - rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. -Qed. - -Hint Extern 5 => -match goal with -| [ |- (Pos.max ?x ?y <= ?z)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (?z <= Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (Pos.max ?x ?y < ?z)%positive ] => - apply Pos.max_case_strong; intros; lia -| [ |- (?z < Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; lia -| _ => lia -end : core. -Hint Resolve Pos.le_max_r Pos.le_max_l : core. - -Hint Constructors valid linear : core. - -(* Compatibility of validity w.r.t algebraic operations *) - -Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> - valid (Pos.max kl kr) (poly_add pl pr). -Proof. -intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. -{ eapply valid_le_compat; [clear k|apply Pos.le_max_r]. - now induction Hr; auto. } -{ assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto. - apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption]. - clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr. - constructor; auto. - now rewrite <- (Pos.max_id i); intuition. - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; lia. - + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; lia. - + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. - + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. -} -Qed. - -Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p). -Proof. -intros k v p H; induction H; simpl; [now auto|]. -case_decide; [|now auto]. -eapply (valid_le_compat i); [now auto|lia]. -Qed. - -Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. -Proof. -intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition. -Qed. - -Lemma poly_mul_mon_valid_compat : forall k i p, - valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p). -Proof. -intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition. -+ apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition. - - match goal with [ H : null ?p |- _ ] => solve[inversion H] end. -+ apply (valid_le_compat k); auto; constructor; intuition. - - assert (X := poly_mul_mon_null_compat); intuition eauto. - - enough (Pos.max (Pos.succ i) i0 = i0) as <-; intuition. - - enough (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0) as <-; intuition. -Qed. - -Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr -> - valid (Pos.max kl kr) (poly_mul pl pr). -Proof. -intros kl kr pl pr Hl Hr; revert kr pr Hr. -induction Hl; intros kr pr Hr; simpl. -+ apply poly_mul_cst_valid_compat; auto. - apply (valid_le_compat kr); now auto. -+ apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))). - - case_decide. - { apply (valid_le_compat (Pos.max i kr)); auto. } - { apply poly_add_valid_compat; auto. - now apply poly_mul_mon_valid_compat; intuition. } - - repeat apply Pos.max_case_strong; lia. -Qed. - -(* Compatibility of linearity wrt to linear operations *) - -Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr -> - linear (Pos.max kl kr) (poly_add pl pr). -Proof. -intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl. -+ apply (linear_le_compat kr); [|apply Pos.max_case_strong; lia]. - now induction Hr; constructor; auto. -+ apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto]. - induction Hr; simpl. - - constructor; auto. - replace i with (Pos.max i i) by (apply Pos.max_id); intuition. - - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. } - { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. } - { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. } -Qed. - -End Algebra. - -Section Reduce. - -(* A stronger version of the next lemma *) - -Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p -> - (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p). -Proof. -intros k p var; revert k; induction p; intros k Hv; simpl; auto. -inversion Hv; case_decide; subst. -+ rewrite poly_add_compat; ring_simplify. - specialize (IHp1 k); specialize (IHp2 k). - destruct (list_nth k var false); ring_simplify; [|now auto]. - rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)). - rewrite <- IHp2; auto; rewrite <- IHp1; [ring|]. - apply (valid_le_compat k); [now auto|lia]. -+ remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto]. - case_decide; simpl. - - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl. - replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k). - { rewrite <- Heqb; ring. } - { apply (valid_le_compat p2); [auto|lia]. } - - rewrite (IHp2 p2); [|now auto]. - replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring). - rewrite <- (IHp1 k); [rewrite <- Heqb; ring|]. - apply (valid_le_compat p2); [auto|lia]. -Qed. - -(* Reduction preserves evaluation by boolean assignations *) - -Lemma reduce_eval_compat : forall k p var, valid k p -> - eval var (reduce p) = eval var p. -Proof. -intros k p var H; induction H; simpl; auto. -case_decide; try_rewrite; simpl. -+ rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring. -+ repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto. -Qed. - -Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive -> - reduce_aux l p = reduce_aux k p. -Proof. -intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto. -inversion H; subst; repeat case_decide; subst; try lia. -+ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|lia]. -+ f_equal; apply IHp1; auto. - now eapply valid_le_compat; [eauto|lia]. -Qed. - -(* Reduce projects valid polynomials into linear ones *) - -Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p). -Proof. -intros i p; revert i; induction p; intros i Hp; simpl. -+ constructor. -+ inversion Hp; subst; case_decide; subst. - - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat. - { apply IHp1; eapply valid_le_compat; [eassumption|lia]. } - { intuition. } - - case_decide. - { apply IHp1; eapply valid_le_compat; [eauto|lia]. } - { constructor; try lia; auto. - erewrite (reduce_aux_le_compat p2); [|assumption|lia]. - apply IHp1; eapply valid_le_compat; [eauto|]; lia. } -Qed. - -Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p). -Proof. -intros k p H; induction H; simpl. -+ now constructor. -+ case_decide. - - eapply linear_le_compat; [eauto|lia]. - - constructor; auto. - apply linear_reduce_aux; auto. -Qed. - -End Reduce. diff --git a/plugins/btauto/Btauto.v b/plugins/btauto/Btauto.v deleted file mode 100644 index d3331ccf89..0000000000 --- a/plugins/btauto/Btauto.v +++ /dev/null @@ -1,3 +0,0 @@ -Require Import Algebra Reflect. - -Declare ML Module "btauto_plugin". diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v deleted file mode 100644 index 867fe69550..0000000000 --- a/plugins/btauto/Reflect.v +++ /dev/null @@ -1,411 +0,0 @@ -Require Import Bool DecidableClass Algebra Ring PArith Lia. - -Section Bool. - -(* Boolean formulas and their evaluations *) - -Inductive formula := -| formula_var : positive -> formula -| formula_btm : formula -| formula_top : formula -| formula_cnj : formula -> formula -> formula -| formula_dsj : formula -> formula -> formula -| formula_neg : formula -> formula -| formula_xor : formula -> formula -> formula -| formula_ifb : formula -> formula -> formula -> formula. - -Fixpoint formula_eval var f := match f with -| formula_var x => list_nth x var false -| formula_btm => false -| formula_top => true -| formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr) -| formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr) -| formula_neg f => negb (formula_eval var f) -| formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr) -| formula_ifb fc fl fr => - if formula_eval var fc then formula_eval var fl else formula_eval var fr -end. - -End Bool. - -(* Translation of formulas into polynomials *) - -Section Translation. - -(* This is straightforward. *) - -Fixpoint poly_of_formula f := match f with -| formula_var x => Poly (Cst false) x (Cst true) -| formula_btm => Cst false -| formula_top => Cst true -| formula_cnj fl fr => - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_mul pl pr -| formula_dsj fl fr => - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_add (poly_add pl pr) (poly_mul pl pr) -| formula_neg f => poly_add (Cst true) (poly_of_formula f) -| formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr) -| formula_ifb fc fl fr => - let pc := poly_of_formula fc in - let pl := poly_of_formula fl in - let pr := poly_of_formula fr in - poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr)) -end. - -Opaque poly_add. - -(* Compatibility of translation wrt evaluation *) - -Lemma poly_of_formula_eval_compat : forall var f, - eval var (poly_of_formula f) = formula_eval var f. -Proof. -intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. - now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end. - rewrite poly_mul_compat, IHf1, IHf2; ring. - repeat rewrite poly_add_compat. - rewrite poly_mul_compat; try_rewrite. - now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end. - rewrite poly_add_compat; try_rewrite. - now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end. - rewrite poly_add_compat; congruence. - rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite. - match goal with - [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity - end. -Qed. - -Hint Extern 5 => change 0 with (min 0 0) : core. -Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. -Local Hint Constructors valid : core. -Hint Extern 5 => lia : core. - -(* Compatibility with validity *) - -Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f). -Proof. -intros f; induction f; simpl. -+ exists (Pos.succ p); constructor; intuition; inversion H. -+ exists 1%positive; auto. -+ exists 1%positive; auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto. -+ destruct IHf as [n Hn]; exists (Pos.max 1 n); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto. -+ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto. -Qed. - -(* The soundness lemma ; alas not complete! *) - -Lemma poly_of_formula_sound : forall fl fr var, - poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Heq. -repeat rewrite <- poly_of_formula_eval_compat. -rewrite Heq; reflexivity. -Qed. - -End Translation. - -Section Completeness. - -(* Lemma reduce_poly_of_formula_simpl : forall fl fr var, - simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) -> - formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Hrw. -do 2 rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption]. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption]. -do 2 rewrite <- eval_simpl_eval_compat; assumption. -Qed. *) - -(* Soundness of the method ; immediate *) - -Lemma reduce_poly_of_formula_sound : forall fl fr var, - reduce (poly_of_formula fl) = reduce (poly_of_formula fr) -> - formula_eval var fl = formula_eval var fr. -Proof. -intros fl fr var Heq. -repeat rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. -rewrite Heq; reflexivity. -Qed. - -Definition make_last {A} n (x def : A) := - Pos.peano_rect (fun _ => list A) - (cons x nil) - (fun _ F => cons def F) n. - -(* Replace the nth element of a list *) - -Fixpoint list_replace l n b := -match l with -| nil => make_last n b false -| cons a l => - Pos.peano_rect _ - (cons b l) (fun n _ => cons a (list_replace l n b)) n -end. - -(** Extract a non-null witness from a polynomial *) - -Existing Instance Decidable_null. - -Fixpoint boolean_witness p := -match p with -| Cst c => nil -| Poly p i q => - if decide (null p) then - let var := boolean_witness q in - list_replace var i true - else - let var := boolean_witness p in - list_replace var i false -end. - -Lemma list_nth_base : forall A (def : A) l, - list_nth 1 l def = match l with nil => def | cons x _ => x end. -Proof. -intros A def l; unfold list_nth. -rewrite Pos.peano_rect_base; reflexivity. -Qed. - -Lemma list_nth_succ : forall A n (def : A) l, - list_nth (Pos.succ n) l def = - match l with nil => def | cons _ l => list_nth n l def end. -Proof. -intros A def l; unfold list_nth. -rewrite Pos.peano_rect_succ; reflexivity. -Qed. - -Lemma list_nth_nil : forall A n (def : A), - list_nth n nil def = def. -Proof. -intros A n def; induction n using Pos.peano_rect. -+ rewrite list_nth_base; reflexivity. -+ rewrite list_nth_succ; reflexivity. -Qed. - -Lemma make_last_nth_1 : forall A n i x def, i <> n -> - list_nth i (@make_last A n x def) def = def. -Proof. -intros A n; induction n using Pos.peano_rect; intros i x def Hd; - unfold make_last; simpl. -+ induction i using Pos.peano_case; [elim Hd; reflexivity|]. - rewrite list_nth_succ, list_nth_nil; reflexivity. -+ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). - induction i using Pos.peano_case. - - rewrite list_nth_base; reflexivity. - - rewrite list_nth_succ; apply IHn; lia. -Qed. - -Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x. -Proof. -intros A n; induction n using Pos.peano_rect; intros x def; simpl. -+ reflexivity. -+ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def). - rewrite list_nth_succ; auto. -Qed. - -Lemma list_replace_nth_1 : forall var i j x, i <> j -> - list_nth i (list_replace var j x) false = list_nth i var false. -Proof. -intros var; induction var; intros i j x Hd; simpl. -+ rewrite make_last_nth_1, list_nth_nil; auto. -+ induction j using Pos.peano_rect. - - rewrite Pos.peano_rect_base. - induction i using Pos.peano_rect; [now elim Hd; auto|]. - rewrite 2list_nth_succ; reflexivity. - - rewrite Pos.peano_rect_succ. - induction i using Pos.peano_rect. - { rewrite 2list_nth_base; reflexivity. } - { rewrite 2list_nth_succ; apply IHvar; lia. } -Qed. - -Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x. -Proof. -intros var; induction var; intros i x; simpl. -+ now apply make_last_nth_2. -+ induction i using Pos.peano_rect. - - rewrite Pos.peano_rect_base, list_nth_base; reflexivity. - - rewrite Pos.peano_rect_succ, list_nth_succ; auto. -Qed. - -(* The witness is correct only if the polynomial is linear *) - -Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p -> - eval (boolean_witness p) p = true. -Proof. -intros k p Hl Hp; induction Hl; simpl. - destruct c; [reflexivity|elim Hp; now constructor]. - case_decide. - rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl. - match goal with [ |- (if ?b then true else false) = true ] => - assert (Hrw : b = true); [|rewrite Hrw; reflexivity] - end. - erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; lia. - rewrite list_replace_nth_2, xorb_false_r. - erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto]. - now intros j Hd; apply list_replace_nth_1; lia. -Qed. - -(* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *) - -Lemma reduce_poly_of_formula_sound_alt : forall var fl fr, - reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false -> - formula_eval var fl = formula_eval var fr. -Proof. -intros var fl fr Heq. -repeat rewrite <- poly_of_formula_eval_compat. -destruct (poly_of_formula_valid_compat fl) as [nl Hl]. -destruct (poly_of_formula_valid_compat fr) as [nr Hr]. -rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto. -rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto. -rewrite <- xorb_false_l; change false with (eval var (Cst false)). -rewrite <- poly_add_compat, <- Heq. -repeat rewrite poly_add_compat. -rewrite (reduce_eval_compat nl); [|assumption]. -rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption]. -rewrite (reduce_eval_compat nr); [|assumption]. -rewrite poly_add_compat; ring. -Qed. - -(* The completeness lemma *) - -(* Lemma reduce_poly_of_formula_complete : forall fl fr, - reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) -> - {var | formula_eval var fl <> formula_eval var fr}. -Proof. -intros fl fr H. -pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))). -pose (var := boolean_witness p). -exists var. - intros Hc; apply (f_equal Z_of_bool) in Hc. - assert (Hfl : linear 0 (reduce (poly_of_formula fl))). - now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. - assert (Hfr : linear 0 (reduce (poly_of_formula fr))). - now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto. - repeat rewrite <- poly_of_formula_eval_compat in Hc. - define (decide (null p)) b Hb; destruct b; tac_decide. - now elim H; apply (null_sub_implies_eq 0 0); fold p; auto; - apply linear_valid_incl; auto. - elim (boolean_witness_nonzero 0 p); auto. - unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto. - unfold p at 2; rewrite poly_add_compat, poly_opp_compat. - destruct (poly_of_formula_valid_compat fl) as [nl Hnl]. - destruct (poly_of_formula_valid_compat fr) as [nr Hnr]. - repeat erewrite reduce_eval_compat; eauto. - fold var; rewrite Hc; ring. -Defined. *) - -End Completeness. - -(* Reification tactics *) - -(* For reflexivity purposes, that would better be transparent *) - -Global Transparent decide poly_add. - -(* Ltac append_var x l k := -match l with -| nil => constr: (k, cons x l) -| cons x _ => constr: (k, l) -| cons ?y ?l => - let ans := append_var x l (S k) in - match ans with (?k, ?l) => constr: (k, cons y l) end -end. - -Ltac build_formula t l := -match t with -| true => constr: (formula_top, l) -| false => constr: (formula_btm, l) -| ?fl && ?fr => - match build_formula fl l with (?tl, ?l) => - match build_formula fr l with (?tr, ?l) => - constr: (formula_cnj tl tr, l) - end - end -| ?fl || ?fr => - match build_formula fl l with (?tl, ?l) => - match build_formula fr l with (?tr, ?l) => - constr: (formula_dsj tl tr, l) - end - end -| negb ?f => - match build_formula f l with (?t, ?l) => - constr: (formula_neg t, l) - end -| _ => - let ans := append_var t l 0 in - match ans with (?k, ?l) => constr: (formula_var k, l) end -end. - -(* Extract a counterexample from a polynomial and display it *) - -Ltac counterexample p l := - let var := constr: (boolean_witness p) in - let var := eval vm_compute in var in - let rec print l vl := - match l with - | nil => idtac - | cons ?x ?l => - match vl with - | nil => - idtac x ":=" "false"; print l (@nil bool) - | cons ?v ?vl => - idtac x ":=" v; print l vl - end - end - in - idtac "Counter-example:"; print l var. - -Ltac btauto_reify := -lazymatch goal with -| [ |- @eq bool ?t ?u ] => - lazymatch build_formula t (@nil bool) with - | (?fl, ?l) => - lazymatch build_formula u l with - | (?fr, ?l) => - change (formula_eval l fl = formula_eval l fr) - end - end -| _ => fail "Cannot recognize a boolean equality" -end. - -(* The long-awaited tactic *) - -Ltac btauto := -lazymatch goal with -| [ |- @eq bool ?t ?u ] => - lazymatch build_formula t (@nil bool) with - | (?fl, ?l) => - lazymatch build_formula u l with - | (?fr, ?l) => - change (formula_eval l fl = formula_eval l fr); - apply reduce_poly_of_formula_sound_alt; - vm_compute; (reflexivity || fail "Not a tautology") - end - end -| _ => fail "Cannot recognize a boolean equality" -end. *) - -Register formula_var as plugins.btauto.f_var. -Register formula_btm as plugins.btauto.f_btm. -Register formula_top as plugins.btauto.f_top. -Register formula_cnj as plugins.btauto.f_cnj. -Register formula_dsj as plugins.btauto.f_dsj. -Register formula_neg as plugins.btauto.f_neg. -Register formula_xor as plugins.btauto.f_xor. -Register formula_ifb as plugins.btauto.f_ifb. - -Register formula_eval as plugins.btauto.eval. -Register boolean_witness as plugins.btauto.witness. -Register reduce_poly_of_formula_sound_alt as plugins.btauto.soundness. diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v deleted file mode 100644 index d1046ae79b..0000000000 --- a/plugins/derive/Derive.v +++ /dev/null @@ -1 +0,0 @@ -Declare ML Module "derive_plugin". diff --git a/plugins/extraction/ExtrHaskellBasic.v b/plugins/extraction/ExtrHaskellBasic.v deleted file mode 100644 index d08a81da64..0000000000 --- a/plugins/extraction/ExtrHaskellBasic.v +++ /dev/null @@ -1,17 +0,0 @@ -(** Extraction to Haskell : use of basic Haskell types *) - -Require Coq.extraction.Extraction. - -Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. -Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. -Extract Inductive unit => "()" [ "()" ]. -Extract Inductive list => "([])" [ "([])" "(:)" ]. -Extract Inductive prod => "(,)" [ "(,)" ]. - -Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. -Extract Inductive sumor => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. -Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ]. - -Extract Inlined Constant andb => "(Prelude.&&)". -Extract Inlined Constant orb => "(Prelude.||)". -Extract Inlined Constant negb => "Prelude.not". diff --git a/plugins/extraction/ExtrHaskellNatInt.v b/plugins/extraction/ExtrHaskellNatInt.v deleted file mode 100644 index 267322d9ed..0000000000 --- a/plugins/extraction/ExtrHaskellNatInt.v +++ /dev/null @@ -1,15 +0,0 @@ -(** Extraction of [nat] into Haskell's [Int] *) - -Require Coq.extraction.Extraction. - -Require Import Arith. -Require Import ExtrHaskellNatNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [nat] into [Int] is definitively *not* a good idea. - * See comments in [ExtrOcamlNatInt.v]. - *) - -Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] - "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/plugins/extraction/ExtrHaskellNatInteger.v b/plugins/extraction/ExtrHaskellNatInteger.v deleted file mode 100644 index 4c5c71f58a..0000000000 --- a/plugins/extraction/ExtrHaskellNatInteger.v +++ /dev/null @@ -1,15 +0,0 @@ -(** Extraction of [nat] into Haskell's [Integer] *) - -Require Coq.extraction.Extraction. - -Require Import Arith. -Require Import ExtrHaskellNatNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [nat] into [Integer] isn't necessarily a good idea. - * See comments in [ExtrOcamlNatInt.v]. -*) - -Extract Inductive nat => "Prelude.Integer" [ "0" "Prelude.succ" ] - "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/plugins/extraction/ExtrHaskellNatNum.v b/plugins/extraction/ExtrHaskellNatNum.v deleted file mode 100644 index 09b0444614..0000000000 --- a/plugins/extraction/ExtrHaskellNatNum.v +++ /dev/null @@ -1,37 +0,0 @@ -(** - * Efficient (but uncertified) extraction of usual [nat] functions - * into equivalent versions in Haskell's Prelude that are defined - * for any [Num] typeclass instances. Useful in combination with - * [Extract Inductive nat] that maps [nat] onto a Haskell type that - * implements [Num]. - *) - -Require Coq.extraction.Extraction. - -Require Import Arith. -Require Import EqNat. - -Extract Inlined Constant Nat.add => "(Prelude.+)". -Extract Inlined Constant Nat.mul => "(Prelude.*)". -Extract Inlined Constant Nat.max => "Prelude.max". -Extract Inlined Constant Nat.min => "Prelude.min". -Extract Inlined Constant Init.Nat.add => "(Prelude.+)". -Extract Inlined Constant Init.Nat.mul => "(Prelude.*)". -Extract Inlined Constant Init.Nat.max => "Prelude.max". -Extract Inlined Constant Init.Nat.min => "Prelude.min". -Extract Inlined Constant Compare_dec.lt_dec => "(Prelude.<)". -Extract Inlined Constant Compare_dec.leb => "(Prelude.<=)". -Extract Inlined Constant Compare_dec.le_lt_dec => "(Prelude.<=)". -Extract Inlined Constant EqNat.beq_nat => "(Prelude.==)". -Extract Inlined Constant EqNat.eq_nat_decide => "(Prelude.==)". -Extract Inlined Constant Peano_dec.eq_nat_dec => "(Prelude.==)". - -Extract Constant Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". -Extract Constant Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". -Extract Constant Init.Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". -Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". - -Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". -Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v deleted file mode 100644 index 8c61f4e96b..0000000000 --- a/plugins/extraction/ExtrHaskellString.v +++ /dev/null @@ -1,62 +0,0 @@ -(** - * Special handling of ascii and strings for extraction to Haskell. - *) - -Require Coq.extraction.Extraction. - -Require Import Ascii. -Require Import String. -Require Import Coq.Strings.Byte. - -(** - * At the moment, Coq's extraction has no way to add extra import - * statements to the extracted Haskell code. You will have to - * manually add: - * - * import qualified Data.Bits - * import qualified Data.Char - *) - -Extract Inductive ascii => "Prelude.Char" - [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr ( - (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+ - (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+ - (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+ - (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+ - (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+ - (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+ - (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+ - (if b7 then Data.Bits.shiftL 1 7 else 0)))" ] - "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0) - (Data.Bits.testBit (Data.Char.ord a) 1) - (Data.Bits.testBit (Data.Char.ord a) 2) - (Data.Bits.testBit (Data.Char.ord a) 3) - (Data.Bits.testBit (Data.Char.ord a) 4) - (Data.Bits.testBit (Data.Char.ord a) 5) - (Data.Bits.testBit (Data.Char.ord a) 6) - (Data.Bits.testBit (Data.Char.ord a) 7))". -Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". -Extract Inlined Constant Ascii.eqb => "(Prelude.==)". - -Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. -Extract Inlined Constant String.string_dec => "(Prelude.==)". -Extract Inlined Constant String.eqb => "(Prelude.==)". - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => "Prelude.Char" -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(Prelude.==)". -Extract Inlined Constant Byte.byte_eq_dec => "(Prelude.==)". -Extract Inlined Constant Ascii.ascii_of_byte => "(\x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(\x -> x)". - -(* -Require Import ExtrHaskellBasic. -Definition test := "ceci est un test"%string. -Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). -Definition test3 := List.map ascii_of_nat (List.seq 0 256). - -Extraction Language Haskell. -Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. -*) diff --git a/plugins/extraction/ExtrHaskellZInt.v b/plugins/extraction/ExtrHaskellZInt.v deleted file mode 100644 index 0345ffc4e8..0000000000 --- a/plugins/extraction/ExtrHaskellZInt.v +++ /dev/null @@ -1,26 +0,0 @@ -(** Extraction of [Z] into Haskell's [Int] *) - -Require Coq.extraction.Extraction. - -Require Import ZArith. -Require Import ExtrHaskellZNum. - -(** - * Disclaimer: trying to obtain efficient certified programs - * by extracting [Z] into [Int] is definitively *not* a good idea. - * See comments in [ExtrOcamlNatInt.v]. - *) - -Extract Inductive positive => "Prelude.Int" [ - "(\x -> 2 Prelude.* x Prelude.+ 1)" - "(\x -> 2 Prelude.* x)" - "1" ] - "(\fI fO fH n -> if n Prelude.== 1 then fH () else - if Prelude.odd n - then fI (n `Prelude.div` 2) - else fO (n `Prelude.div` 2))". - -Extract Inductive Z => "Prelude.Int" [ "0" "(\x -> x)" "Prelude.negate" ] - "(\fO fP fN n -> if n Prelude.== 0 then fO () else - if n Prelude.> 0 then fP n else - fN (Prelude.negate n))". diff --git a/plugins/extraction/ExtrHaskellZInteger.v b/plugins/extraction/ExtrHaskellZInteger.v deleted file mode 100644 index f7f9e2f80d..0000000000 --- a/plugins/extraction/ExtrHaskellZInteger.v +++ /dev/null @@ -1,25 +0,0 @@ -(** Extraction of [Z] into Haskell's [Integer] *) - -Require Coq.extraction.Extraction. - -Require Import ZArith. -Require Import ExtrHaskellZNum. - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [Z] into [Integer] isn't necessarily a good idea. - See comments in [ExtrOcamlNatInt.v]. -*) - -Extract Inductive positive => "Prelude.Integer" [ - "(\x -> 2 Prelude.* x Prelude.+ 1)" - "(\x -> 2 Prelude.* x)" - "1" ] - "(\fI fO fH n -> if n Prelude.== 1 then fH () else - if Prelude.odd n - then fI (n `Prelude.div` 2) - else fO (n `Prelude.div` 2))". - -Extract Inductive Z => "Prelude.Integer" [ "0" "(\x -> x)" "Prelude.negate" ] - "(\fO fP fN n -> if n Prelude.== 0 then fO () else - if n Prelude.> 0 then fP n else - fN (Prelude.negate n))". diff --git a/plugins/extraction/ExtrHaskellZNum.v b/plugins/extraction/ExtrHaskellZNum.v deleted file mode 100644 index 4141bd203f..0000000000 --- a/plugins/extraction/ExtrHaskellZNum.v +++ /dev/null @@ -1,23 +0,0 @@ -(** - * Efficient (but uncertified) extraction of usual [Z] functions - * into equivalent versions in Haskell's Prelude that are defined - * for any [Num] typeclass instances. Useful in combination with - * [Extract Inductive Z] that maps [Z] onto a Haskell type that - * implements [Num]. - *) - -Require Coq.extraction.Extraction. - -Require Import ZArith. -Require Import EqNat. - -Extract Inlined Constant Z.add => "(Prelude.+)". -Extract Inlined Constant Z.sub => "(Prelude.-)". -Extract Inlined Constant Z.mul => "(Prelude.*)". -Extract Inlined Constant Z.max => "Prelude.max". -Extract Inlined Constant Z.min => "Prelude.min". -Extract Inlined Constant Z_ge_lt_dec => "(Prelude.>=)". -Extract Inlined Constant Z_gt_le_dec => "(Prelude.>)". - -Extract Constant Z.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Z.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". diff --git a/plugins/extraction/ExtrOCamlFloats.v b/plugins/extraction/ExtrOCamlFloats.v deleted file mode 100644 index 1891772cc2..0000000000 --- a/plugins/extraction/ExtrOCamlFloats.v +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction to OCaml of native binary64 floating-point numbers. - -Note: the extraction of primitive floats relies on Coq's internal file -kernel/float64.ml, so make sure the corresponding binary is available -when linking the extracted OCaml code. - -For example, if you build a (_CoqProject + coq_makefile)-based project -and if you created an empty subfolder "extracted" and a file "test.v" -containing [Cd "extracted". Separate Extraction function_to_extract.], -you will just need to add in the _CoqProject: [test.v], [-I extracted] -and the list of [extracted/*.ml] and [extracted/*.mli] files, then add -[CAMLFLAGS += -w -33] in the Makefile.local file. *) - -From Coq Require Floats Extraction. - -(** Basic data types used by some primitive operators. *) - -Extract Inductive bool => bool [ true false ]. -Extract Inductive prod => "( * )" [ "" ]. - -Extract Inductive FloatClass.float_class => - "Float64.float_class" - [ "PNormal" "NNormal" "PSubn" "NSubn" "PZero" "NZero" "PInf" "NInf" "NaN" ]. -Extract Inductive PrimFloat.float_comparison => - "Float64.float_comparison" - [ "FEq" "FLt" "FGt" "FNotComparable" ]. - -(** Primitive types and operators. *) - -Extract Constant PrimFloat.float => "Float64.t". -Extraction Inline PrimFloat.float. -(* Otherwise, the name conflicts with the primitive OCaml type [float] *) - -Extract Constant PrimFloat.classify => "Float64.classify". -Extract Constant PrimFloat.abs => "Float64.abs". -Extract Constant PrimFloat.sqrt => "Float64.sqrt". -Extract Constant PrimFloat.opp => "Float64.opp". -Extract Constant PrimFloat.eqb => "Float64.eq". -Extract Constant PrimFloat.ltb => "Float64.lt". -Extract Constant PrimFloat.leb => "Float64.le". -Extract Constant PrimFloat.compare => "Float64.compare". -Extract Constant PrimFloat.mul => "Float64.mul". -Extract Constant PrimFloat.add => "Float64.add". -Extract Constant PrimFloat.sub => "Float64.sub". -Extract Constant PrimFloat.div => "Float64.div". -Extract Constant PrimFloat.of_int63 => "Float64.of_int63". -Extract Constant PrimFloat.normfr_mantissa => "Float64.normfr_mantissa". -Extract Constant PrimFloat.frshiftexp => "Float64.frshiftexp". -Extract Constant PrimFloat.ldshiftexp => "Float64.ldshiftexp". -Extract Constant PrimFloat.next_up => "Float64.next_up". -Extract Constant PrimFloat.next_down => "Float64.next_down". diff --git a/plugins/extraction/ExtrOCamlInt63.v b/plugins/extraction/ExtrOCamlInt63.v deleted file mode 100644 index a2ee602313..0000000000 --- a/plugins/extraction/ExtrOCamlInt63.v +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction to OCaml of native 63-bit machine integers. *) - -From Coq Require Int63 Extraction. - -(** Basic data types used by some primitive operators. *) - -Extract Inductive bool => bool [ true false ]. -Extract Inductive prod => "( * )" [ "" ]. -Extract Inductive comparison => int [ "0" "(-1)" "1" ]. -Extract Inductive DoubleType.carry => "Uint63.carry" [ "Uint63.C0" "Uint63.C1" ]. - -(** Primitive types and operators. *) -Extract Constant Int63.int => "Uint63.t". -Extraction Inline Int63.int. -(* Otherwise, the name conflicts with the primitive OCaml type [int] *) - -Extract Constant Int63.lsl => "Uint63.l_sl". -Extract Constant Int63.lsr => "Uint63.l_sr". -Extract Constant Int63.land => "Uint63.l_and". -Extract Constant Int63.lor => "Uint63.l_or". -Extract Constant Int63.lxor => "Uint63.l_xor". - -Extract Constant Int63.add => "Uint63.add". -Extract Constant Int63.sub => "Uint63.sub". -Extract Constant Int63.mul => "Uint63.mul". -Extract Constant Int63.mulc => "Uint63.mulc". -Extract Constant Int63.div => "Uint63.div". -Extract Constant Int63.mod => "Uint63.rem". - -Extract Constant Int63.eqb => "Uint63.equal". -Extract Constant Int63.ltb => "Uint63.lt". -Extract Constant Int63.leb => "Uint63.le". - -Extract Constant Int63.addc => "Uint63.addc". -Extract Constant Int63.addcarryc => "Uint63.addcarryc". -Extract Constant Int63.subc => "Uint63.subc". -Extract Constant Int63.subcarryc => "Uint63.subcarryc". - -Extract Constant Int63.diveucl => "Uint63.diveucl". -Extract Constant Int63.diveucl_21 => "Uint63.div21". -Extract Constant Int63.addmuldiv => "Uint63.addmuldiv". - -Extract Constant Int63.compare => "Uint63.compare". - -Extract Constant Int63.head0 => "Uint63.head0". -Extract Constant Int63.tail0 => "Uint63.tail0". diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v deleted file mode 100644 index 2f82b24862..0000000000 --- a/plugins/extraction/ExtrOcamlBasic.v +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Coq.extraction.Extraction. - -(** Extraction to Ocaml : use of basic Ocaml types *) - -Extract Inductive bool => bool [ true false ]. -Extract Inductive option => option [ Some None ]. -Extract Inductive unit => unit [ "()" ]. -Extract Inductive list => list [ "[]" "( :: )" ]. -Extract Inductive prod => "( * )" [ "" ]. - -(** NB: The "" above is a hack, but produce nicer code than "(,)" *) - -(** Mapping sumbool to bool and sumor to option is not always nicer, - but it helps when realizing stuff like [lt_eq_lt_dec] *) - -Extract Inductive sumbool => bool [ true false ]. -Extract Inductive sumor => option [ Some None ]. - -(** Restore laziness of andb, orb. - NB: without these Extract Constant, andb/orb would be inlined - by extraction in order to have laziness, producing inelegant - (if ... then ... else false) and (if ... then true else ...). -*) - -Extract Inlined Constant andb => "(&&)". -Extract Inlined Constant orb => "(||)". - diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v deleted file mode 100644 index f8bc86d087..0000000000 --- a/plugins/extraction/ExtrOcamlBigIntConv.v +++ /dev/null @@ -1,112 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction to Ocaml: conversion from/to [big_int] *) - -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) - -Require Coq.extraction.Extraction. - -Require Import Arith ZArith. - -Parameter bigint : Type. -Parameter bigint_zero : bigint. -Parameter bigint_succ : bigint -> bigint. -Parameter bigint_opp : bigint -> bigint. -Parameter bigint_twice : bigint -> bigint. - -Extract Inlined Constant bigint => "Big.big_int". -Extract Inlined Constant bigint_zero => "Big.zero". -Extract Inlined Constant bigint_succ => "Big.succ". -Extract Inlined Constant bigint_opp => "Big.opp". -Extract Inlined Constant bigint_twice => "Big.double". - -Definition bigint_of_nat : nat -> bigint := - (fix loop acc n := - match n with - | O => acc - | S n => loop (bigint_succ acc) n - end) bigint_zero. - -Fixpoint bigint_of_pos p := - match p with - | xH => bigint_succ bigint_zero - | xO p => bigint_twice (bigint_of_pos p) - | xI p => bigint_succ (bigint_twice (bigint_of_pos p)) - end. - -Fixpoint bigint_of_z z := - match z with - | Z0 => bigint_zero - | Zpos p => bigint_of_pos p - | Zneg p => bigint_opp (bigint_of_pos p) - end. - -Fixpoint bigint_of_n n := - match n with - | N0 => bigint_zero - | Npos p => bigint_of_pos p - end. - -(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and - [pos_of_bigint] are total and return zero (resp. one) for - non-positive inputs. *) - -Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A. -Extract Constant bigint_natlike_rec => "Big.nat_rec". - -Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S. - -Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A. -Extract Constant bigint_poslike_rec => "Big.positive_rec". - -Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH. - -Parameter bigint_zlike_case : - forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A. -Extract Constant bigint_zlike_case => "Big.z_rec". - -Definition z_of_bigint : bigint -> Z := - bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i)) - (fun i => Zneg (pos_of_bigint i)). - -Definition n_of_bigint : bigint -> N := - bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0). - -(* Tests: - -Definition small := 1234%nat. -Definition big := 12345678901234567890%positive. - -Definition nat_0 := nat_of_bigint (bigint_of_nat 0). -Definition nat_1 := nat_of_bigint (bigint_of_nat small). -Definition pos_1 := pos_of_bigint (bigint_of_pos 1). -Definition pos_2 := pos_of_bigint (bigint_of_pos big). -Definition n_0 := n_of_bigint (bigint_of_n 0). -Definition n_1 := n_of_bigint (bigint_of_n 1). -Definition n_2 := n_of_bigint (bigint_of_n (Npos big)). -Definition z_0 := z_of_bigint (bigint_of_z 0). -Definition z_1 := z_of_bigint (bigint_of_z 1). -Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)). -Definition z_m1 := z_of_bigint (bigint_of_z (-1)). -Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)). - -Definition test := - (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2). -Definition check := - (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big). - -Extraction "/tmp/test.ml" check test. - -... and we check that test=check -*) diff --git a/plugins/extraction/ExtrOcamlChar.v b/plugins/extraction/ExtrOcamlChar.v deleted file mode 100644 index 1e68365dd3..0000000000 --- a/plugins/extraction/ExtrOcamlChar.v +++ /dev/null @@ -1,45 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Extraction to Ocaml : extract ascii to OCaml's char type *) - -Require Coq.extraction.Extraction. - -Require Import Ascii String Coq.Strings.Byte. - -Extract Inductive ascii => char -[ -"(* If this appears, you're using Ascii internals. Please don't *) - (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> - let f b i = if b then 1 lsl i else 0 in - Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" -] -"(* If this appears, you're using Ascii internals. Please don't *) - (fun f c -> - let n = Char.code c in - let h i = (n land (1 lsl i)) <> 0 in - f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". - -Extract Constant zero => "'\000'". -Extract Constant one => "'\001'". -Extract Constant shift => - "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". - -Extract Inlined Constant ascii_dec => "(=)". -Extract Inlined Constant Ascii.eqb => "(=)". - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => char -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(=)". -Extract Inlined Constant Byte.byte_eq_dec => "(=)". -Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v deleted file mode 100644 index 2de1906323..0000000000 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction to Ocaml: conversion from/to [int] - - Nota: no check that [int] values aren't generating overflows *) - -Require Coq.extraction.Extraction. - -Require Import Arith ZArith. - -Parameter int : Type. -Parameter int_zero : int. -Parameter int_succ : int -> int. -Parameter int_opp : int -> int. -Parameter int_twice : int -> int. - -Extract Inlined Constant int => int. -Extract Inlined Constant int_zero => "0". -Extract Inlined Constant int_succ => "succ". -Extract Inlined Constant int_opp => "-". -Extract Inlined Constant int_twice => "2 *". - -Definition int_of_nat : nat -> int := - (fix loop acc n := - match n with - | O => acc - | S n => loop (int_succ acc) n - end) int_zero. - -Fixpoint int_of_pos p := - match p with - | xH => int_succ int_zero - | xO p => int_twice (int_of_pos p) - | xI p => int_succ (int_twice (int_of_pos p)) - end. - -Fixpoint int_of_z z := - match z with - | Z0 => int_zero - | Zpos p => int_of_pos p - | Zneg p => int_opp (int_of_pos p) - end. - -Fixpoint int_of_n n := - match n with - | N0 => int_zero - | Npos p => int_of_pos p - end. - -(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and - [pos_of_int] are total and return zero (resp. one) for - non-positive inputs. *) - -Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A. -Extract Constant int_natlike_rec => -"fun fO fS -> - let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1) - in loop fO". - -Definition nat_of_int : int -> nat := int_natlike_rec _ O S. - -Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A. -Extract Constant int_poslike_rec => -"fun f1 f2x f2x1 -> - let rec loop i = if i <= 1 then f1 else - if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1)) - in loop". - -Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI. - -Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A. -Extract Constant int_zlike_case => -"fun f0 fpos fneg i -> - if i = 0 then f0 else if i>0 then fpos i else fneg (-i)". - -Definition z_of_int : int -> Z := - int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i)) - (fun i => Zneg (pos_of_int i)). - -Definition n_of_int : int -> N := - int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0). - -(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int], - since [min_int] has no positive opposite ([-min_int = min_int]). -*) - -(* -Extraction "/tmp/test.ml" - nat_of_int int_of_nat - pos_of_int int_of_pos - z_of_int int_of_z - n_of_int int_of_n. -*) diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v deleted file mode 100644 index a66d6e41fd..0000000000 --- a/plugins/extraction/ExtrOcamlNatBigInt.v +++ /dev/null @@ -1,73 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction of [nat] into Ocaml's [big_int] *) - -Require Coq.extraction.Extraction. - -Require Import Arith Even Div2 EqNat Euclid. -Require Import ExtrOcamlBasic. - -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [nat] into [big_int] isn't necessarily a good idea. - See comments in [ExtrOcamlNatInt.v]. -*) - - -(** Mapping of [nat] into [big_int]. The last string corresponds to - a [nat_case], see documentation of [Extract Inductive]. *) - -Extract Inductive nat => "Big.big_int" [ "Big.zero" "Big.succ" ] - "Big.nat_case". - -(** Efficient (but uncertified) versions for usual [nat] functions *) - -Extract Constant plus => "Big.add". -Extract Constant mult => "Big.mult". -Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)". -Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)". -Extract Constant max => "Big.max". -Extract Constant min => "Big.min". -(*Extract Constant nat_beq => "Big.eq".*) -Extract Constant EqNat.beq_nat => "Big.eq". -Extract Constant EqNat.eq_nat_decide => "Big.eq". - -Extract Constant Peano_dec.eq_nat_dec => "Big.eq". - -Extract Constant Nat.compare => - "Big.compare_case Eq Lt Gt". - -Extract Constant Compare_dec.leb => "Big.le". -Extract Constant Compare_dec.le_lt_dec => "Big.le". -Extract Constant Compare_dec.lt_eq_lt_dec => - "Big.compare_case (Some false) (Some true) None". - -Extract Constant Even.even_odd_dec => - "fun n -> Big.sign (Big.mod n Big.two) = 0". -Extract Constant Div2.div2 => "fun n -> Big.div n Big.two". - -Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""]. -Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n". -Extract Constant Euclid.quotient => "fun n m -> Big.div m n". -Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n". - -(* -Require Import Euclid. -Definition test n m (H:m>0) := - let (q,r,_,_) := eucl_dev m H n in - nat_compare n (q*m+r). - -Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2. -*) diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v deleted file mode 100644 index 406a7f0d2b..0000000000 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction of [nat] into Ocaml's [int] *) - -Require Coq.extraction.Extraction. - -Require Import Arith Even Div2 EqNat Euclid. -Require Import ExtrOcamlBasic. - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [nat] into [int] is definitively *not* a good idea: - - - This is just a syntactic adaptation, many things can go wrong, - such as name captures (e.g. if you have a constant named "int" - in your development, or a module named "Pervasives"). See bug #2878. - - - Since [int] is bounded while [nat] is (theoretically) infinite, - you have to make sure by yourself that your program will not - manipulate numbers greater than [max_int]. Otherwise you should - consider the translation of [nat] into [big_int]. - - - Moreover, the mere translation of [nat] into [int] does not - change the complexity of functions. For instance, [mult] stays - quadratic. To mitigate this, we propose here a few efficient (but - uncertified) realizers for some common functions over [nat]. - - This file is hence provided mainly for testing / prototyping - purpose. For serious use of numbers in extracted programs, - you are advised to use either coq advanced representations - (positive, Z, N, BigN, BigZ) or modular/axiomatic representation. -*) - - -(** Mapping of [nat] into [int]. The last string corresponds to - a [nat_case], see documentation of [Extract Inductive]. *) - -Extract Inductive nat => int [ "0" "Pervasives.succ" ] - "(fun fO fS n -> if n=0 then fO () else fS (n-1))". - -(** Efficient (but uncertified) versions for usual [nat] functions *) - -Extract Constant plus => "(+)". -Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". -Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". -Extract Constant mult => "( * )". -Extract Inlined Constant max => "Pervasives.max". -Extract Inlined Constant min => "Pervasives.min". -(*Extract Inlined Constant nat_beq => "(=)".*) -Extract Inlined Constant EqNat.beq_nat => "(=)". -Extract Inlined Constant EqNat.eq_nat_decide => "(=)". - -Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)". - -Extract Constant Nat.compare => - "fun n m -> if n=m then Eq else if n<m then Lt else Gt". -Extract Inlined Constant Compare_dec.leb => "(<=)". -Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". -Extract Inlined Constant Compare_dec.lt_dec => "(<)". -Extract Constant Compare_dec.lt_eq_lt_dec => - "fun n m -> if n>m then None else Some (n<m)". - -Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0". -Extract Constant Div2.div2 => "fun n -> n/2". - -Extract Inductive Euclid.diveucl => "(int * int)" [ "" ]. -Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)". -Extract Constant Euclid.quotient => "fun n m -> m/n". -Extract Constant Euclid.modulo => "fun n m -> m mod n". - -(* -Definition test n m (H:m>0) := - let (q,r,_,_) := eucl_dev m H n in - nat_compare n (q*m+r). - -Recursive Extraction test fact. -*) diff --git a/plugins/extraction/ExtrOcamlNativeString.v b/plugins/extraction/ExtrOcamlNativeString.v deleted file mode 100644 index ec3da1e444..0000000000 --- a/plugins/extraction/ExtrOcamlNativeString.v +++ /dev/null @@ -1,87 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Extraction to Ocaml : extract ascii to OCaml's char type - and string to OCaml's string type. *) - -Require Coq.extraction.Extraction. - -Require Import Ascii String Coq.Strings.Byte. -Require Export ExtrOcamlChar. - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => char -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(=)". -Extract Inlined Constant Byte.byte_eq_dec => "(=)". -Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". - -(* This differs from ExtrOcamlString.v: the latter extracts "string" - to "char list", and we extract "string" to "string" *) - -Extract Inductive string => "string" -[ -(* EmptyString *) -"(* If this appears, you're using String internals. Please don't *) - """" -" -(* String *) -"(* If this appears, you're using String internals. Please don't *) - (fun (c, s) -> String.make 1 c ^ s) -" -] -"(* If this appears, you're using String internals. Please don't *) - (fun f0 f1 s -> - let l = String.length s in - if l = 0 then f0 else f1 (String.get s 0) (String.sub s 1 (l-1))) -". - -Extract Inlined Constant String.string_dec => "(=)". -Extract Inlined Constant String.eqb => "(=)". -Extract Inlined Constant String.append => "(^)". -Extract Inlined Constant String.concat => "String.concat". -Extract Inlined Constant String.prefix => - "(fun s1 s2 -> - let l1 = String.length s1 and l2 = String.length s2 in - l1 <= l2 && String.sub s2 0 l1 = s1)". -Extract Inlined Constant String.string_of_list_ascii => - "(fun l -> - let a = Array.of_list l in - String.init (Array.length a) (fun i -> a.(i)))". -Extract Inlined Constant String.list_ascii_of_string => - "(fun s -> - Array.to_list (Array.init (String.length s) (fun i -> s.[i])))". -Extract Inlined Constant String.string_of_list_byte => - "(fun l -> - let a = Array.of_list l in - String.init (Array.length a) (fun i -> a.(i)))". -Extract Inlined Constant String.list_byte_of_string => - "(fun s -> - Array.to_list (Array.init (String.length s) (fun i -> s.[i])))". - -(* Other operations in module String (at the time of this writing): - String.length - String.get - String.substring - String.index - String.findex - They all use type "nat". If we know that "nat" extracts - to O | S of nat, we can provide OCaml implementations - for these functions that work directly on OCaml's strings. - However "nat" could be extracted to other OCaml types... -*) - -(* -Definition test := "ceci est un test"%string. - -Recursive Extraction test Ascii.zero Ascii.one. -*) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v deleted file mode 100644 index 18c5ed3fe4..0000000000 --- a/plugins/extraction/ExtrOcamlString.v +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Extraction to Ocaml : special handling of ascii and strings *) - -Require Coq.extraction.Extraction. - -Require Import Ascii String Coq.Strings.Byte. -Require Export ExtrOcamlChar. - -Extract Inductive string => "char list" [ "[]" "(::)" ]. diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v deleted file mode 100644 index c36ea50755..0000000000 --- a/plugins/extraction/ExtrOcamlZBigInt.v +++ /dev/null @@ -1,91 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *) - -Require Coq.extraction.Extraction. - -Require Import ZArith NArith. -Require Import ExtrOcamlBasic. - -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [Z] into [big_int] isn't necessarily a good idea. - See the Disclaimer in [ExtrOcamlNatInt]. *) - -(** Mapping of [positive], [Z], [N] into [big_int]. The last strings - emulate the matching, see documentation of [Extract Inductive]. *) - -Extract Inductive positive => "Big.big_int" - [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case". - -Extract Inductive Z => "Big.big_int" - [ "Big.zero" "" "Big.opp" ] "Big.z_case". - -Extract Inductive N => "Big.big_int" - [ "Big.zero" "" ] "Big.n_case". - -(** Nota: the "" above is used as an identity function "(fun p->p)" *) - -(** Efficient (but uncertified) versions for usual functions *) - -Extract Constant Pos.add => "Big.add". -Extract Constant Pos.succ => "Big.succ". -Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)". -Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)". -Extract Constant Pos.mul => "Big.mult". -Extract Constant Pos.min => "Big.min". -Extract Constant Pos.max => "Big.max". -Extract Constant Pos.compare => - "fun x y -> Big.compare_case Eq Lt Gt x y". -Extract Constant Pos.compare_cont => - "fun c x y -> Big.compare_case c Lt Gt x y". - -Extract Constant N.add => "Big.add". -Extract Constant N.succ => "Big.succ". -Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)". -Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)". -Extract Constant N.mul => "Big.mult". -Extract Constant N.min => "Big.min". -Extract Constant N.max => "Big.max". -Extract Constant N.div => - "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b". -Extract Constant N.modulo => - "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b". -Extract Constant N.compare => "Big.compare_case Eq Lt Gt". - -Extract Constant Z.add => "Big.add". -Extract Constant Z.succ => "Big.succ". -Extract Constant Z.pred => "Big.pred". -Extract Constant Z.sub => "Big.sub". -Extract Constant Z.mul => "Big.mult". -Extract Constant Z.opp => "Big.opp". -Extract Constant Z.abs => "Big.abs". -Extract Constant Z.min => "Big.min". -Extract Constant Z.max => "Big.max". -Extract Constant Z.compare => "Big.compare_case Eq Lt Gt". - -Extract Constant Z.of_N => "fun p -> p". -Extract Constant Z.abs_N => "Big.abs". - -(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). - For the moment we don't even try *) - -(** Test: -Require Import ZArith NArith. - -Extraction "/tmp/test.ml" - Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare - Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo. -*) diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v deleted file mode 100644 index c7343d2468..0000000000 --- a/plugins/extraction/ExtrOcamlZInt.v +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Extraction of [positive], [N] and [Z] into Ocaml's [int] *) - -Require Coq.extraction.Extraction. - -Require Import ZArith NArith. -Require Import ExtrOcamlBasic. - -(** Disclaimer: trying to obtain efficient certified programs - by extracting [Z] into [int] is definitively *not* a good idea. - See the Disclaimer in [ExtrOcamlNatInt]. *) - -(** Mapping of [positive], [Z], [N] into [int]. The last strings - emulate the matching, see documentation of [Extract Inductive]. *) - -Extract Inductive positive => int -[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] -"(fun f2p1 f2p f1 p -> - if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". - -Extract Inductive Z => int [ "0" "" "(~-)" ] -"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". - -Extract Inductive N => int [ "0" "" ] -"(fun f0 fp n -> if n=0 then f0 () else fp n)". - -(** Nota: the "" above is used as an identity function "(fun p->p)" *) - -(** Efficient (but uncertified) versions for usual functions *) - -Extract Constant Pos.add => "(+)". -Extract Constant Pos.succ => "Pervasives.succ". -Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". -Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". -Extract Constant Pos.mul => "( * )". -Extract Constant Pos.min => "Pervasives.min". -Extract Constant Pos.max => "Pervasives.max". -Extract Constant Pos.compare => - "fun x y -> if x=y then Eq else if x<y then Lt else Gt". -Extract Constant Pos.compare_cont => - "fun c x y -> if x=y then c else if x<y then Lt else Gt". - - -Extract Constant N.add => "(+)". -Extract Constant N.succ => "Pervasives.succ". -Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". -Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". -Extract Constant N.mul => "( * )". -Extract Constant N.min => "Pervasives.min". -Extract Constant N.max => "Pervasives.max". -Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". -Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". -Extract Constant N.compare => - "fun x y -> if x=y then Eq else if x<y then Lt else Gt". - - -Extract Constant Z.add => "(+)". -Extract Constant Z.succ => "Pervasives.succ". -Extract Constant Z.pred => "Pervasives.pred". -Extract Constant Z.sub => "(-)". -Extract Constant Z.mul => "( * )". -Extract Constant Z.opp => "(~-)". -Extract Constant Z.abs => "Pervasives.abs". -Extract Constant Z.min => "Pervasives.min". -Extract Constant Z.max => "Pervasives.max". -Extract Constant Z.compare => - "fun x y -> if x=y then Eq else if x<y then Lt else Gt". - -Extract Constant Z.of_N => "fun p -> p". -Extract Constant Z.abs_N => "Pervasives.abs". - -(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). - For the moment we don't even try *) - - diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v deleted file mode 100644 index 207c95247e..0000000000 --- a/plugins/extraction/Extraction.v +++ /dev/null @@ -1,11 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Declare ML Module "extraction_plugin". diff --git a/plugins/fourier/plugin_base.dune b/plugins/fourier/plugin_base.dune deleted file mode 100644 index 8cc76f6f9e..0000000000 --- a/plugins/fourier/plugin_base.dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name fourier_plugin) - (public_name coq.plugins.fourier) - (synopsis "Coq's fourier plugin") - (libraries coq.plugins.ltac)) diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v deleted file mode 100644 index d58b169154..0000000000 --- a/plugins/funind/FunInd.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Coq.extraction.Extraction. -Declare ML Module "recdef_plugin". diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v deleted file mode 100644 index cd3d69861f..0000000000 --- a/plugins/funind/Recdef.v +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Coq.funind.FunInd. -Require Import PeanoNat. -Require Compare_dec. -Require Wf_nat. - -Section Iter. -Variable A : Type. - -Fixpoint iter (n : nat) : (A -> A) -> A -> A := - fun (fl : A -> A) (def : A) => - match n with - | O => def - | S m => fl (iter m fl def) - end. -End Iter. - -Theorem le_lt_SS x y : x <= y -> x < S (S y). -Proof. - intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r. -Qed. - -Theorem Splus_lt x y : y < S (x + y). -Proof. - apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_r. -Qed. - -Theorem SSplus_lt x y : x < S (S (x + y)). -Proof. - apply le_lt_SS, Nat.le_add_r. -Qed. - -Inductive max_type (m n:nat) : Set := - cmt : forall v, m <= v -> n <= v -> max_type m n. - -Definition max m n : max_type m n. -Proof. - destruct (Compare_dec.le_gt_dec m n) as [h|h]. - - exists n; [exact h | apply le_n]. - - exists m; [apply le_n | apply Nat.lt_le_incl; exact h]. -Defined. - -Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100. diff --git a/plugins/ltac/Ltac.v b/plugins/ltac/Ltac.v deleted file mode 100644 index e69de29bb2..0000000000 --- a/plugins/ltac/Ltac.v +++ /dev/null diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v deleted file mode 100644 index 7ad5e313e3..0000000000 --- a/plugins/micromega/DeclConstant.v +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2019 *) -(* *) -(************************************************************************) - -(** Declaring 'allowed' terms using type classes. - - Motivation: reification needs to know which terms are allowed. - For 'lia', the constant are only the integers built from Z0, Zpos, Zneg, xH, xO, xI. - However, if the term is ground it may be convertible to an integer. - Thus we could allow i.e. sqrt z for some integer z. - - Proposal: for each type, the user declares using type-classes the set of allowed ground terms. - *) - -Require Import List. - -(** Declarative definition of constants. - These are ground terms (without variables) of interest. - e.g. nat is built from O and S - NB: this does not need to be restricted to constructors. - *) - -(** Ground terms (see [GT] below) are built inductively from declared constants. *) - -Class DeclaredConstant {T : Type} (F : T). - -Class GT {T : Type} (F : T). - -Instance GT_O {T : Type} (F : T) {DC : DeclaredConstant F} : GT F. -Defined. - -Instance GT_APP1 {T1 T2 : Type} (F : T1 -> T2) (A : T1) : - DeclaredConstant F -> - GT A -> GT (F A). -Defined. - -Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) - {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} : - GT A1 -> GT A2 -> GT (F A1 A2). -Defined. - -Require Import QArith_base. - -Instance DO : DeclaredConstant O := {}. -Instance DS : DeclaredConstant S := {}. -Instance DxH: DeclaredConstant xH := {}. -Instance DxI: DeclaredConstant xI := {}. -Instance DxO: DeclaredConstant xO := {}. -Instance DZO: DeclaredConstant Z0 := {}. -Instance DZpos: DeclaredConstant Zpos := {}. -Instance DZneg: DeclaredConstant Zneg := {}. -Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. -Instance DZpow : DeclaredConstant Z.pow := {}. - -Instance DQ : DeclaredConstant Qmake := {}. diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v deleted file mode 100644 index 8f4d4726b6..0000000000 --- a/plugins/micromega/Env.v +++ /dev/null @@ -1,101 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import BinInt List. -Set Implicit Arguments. -Local Open Scope positive_scope. - -Section S. - - Variable D :Type. - - Definition Env := positive -> D. - - Definition jump (j:positive) (e:Env) := fun x => e (x+j). - - Definition nth (n:positive) (e:Env) := e n. - - Definition hd (e:Env) := nth 1 e. - - Definition tail (e:Env) := jump 1 e. - - Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x. - Proof. - unfold jump. f_equal. apply Pos.add_assoc. - Qed. - - Lemma jump_simpl p l x : - jump p l x = - match p with - | xH => tail l x - | xO p => jump p (jump p l) x - | xI p => jump p (jump p (tail l)) x - end. - Proof. - destruct p; unfold tail; rewrite <- ?jump_add; f_equal; - now rewrite Pos.add_diag. - Qed. - - Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x. - Proof. - unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm. - Qed. - - Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x. - Proof. - rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l. - Qed. - - Lemma jump_pred_double i l x : - jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x. - Proof. - unfold tail. rewrite <- !jump_add. f_equal. - now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. - Qed. - - Lemma nth_spec p l : - nth p l = - match p with - | xH => hd l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - Proof. - unfold hd, nth, tail, jump. - destruct p; f_equal; now rewrite Pos.add_diag. - Qed. - - Lemma nth_jump p l : nth p (tail l) = hd (jump p l). - Proof. - unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm. - Qed. - - Lemma nth_pred_double p l : - nth (Pos.pred_double p) (tail l) = nth p (jump p l). - Proof. - unfold nth, tail, jump. f_equal. - now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. - Qed. - -End S. - -Ltac jump_simpl := - repeat - match goal with - | |- context [jump xH] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p)) - end. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v deleted file mode 100644 index 2762bb6b32..0000000000 --- a/plugins/micromega/EnvRing.v +++ /dev/null @@ -1,1101 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* F. Besson: to evaluate polynomials, the original code is using a list. - For big polynomials, this is inefficient -- linear access. - I have modified the code to use binary trees -- logarithmic access. *) - - -Set Implicit Arguments. -Require Import Setoid Morphisms Env BinPos BinNat BinInt. -Require Export Ring_theory. - -Local Open Scope positive_scope. -Import RingSyntax. - -(** Definition of polynomial expressions *) -#[universes(template)] -Inductive PExpr {C} : Type := -| PEc : C -> PExpr -| PEX : positive -> PExpr -| PEadd : PExpr -> PExpr -> PExpr -| PEsub : PExpr -> PExpr -> PExpr -| PEmul : PExpr -> PExpr -> PExpr -| PEopp : PExpr -> PExpr -| PEpow : PExpr -> N -> PExpr. -Arguments PExpr : clear implicits. - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - -#[universes(template)] -Inductive Pol {C} : Type := -| Pc : C -> Pol -| Pinj : positive -> Pol -> Pol -| PX : Pol -> positive -> Pol -> Pol. -Arguments Pol : clear implicits. - -Section MakeRingPol. - - (* Ring elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Equivalence req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - Infix "==" := req. - Infix "^" := (pow_pos rmul). - - (* C notations *) - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-! " := csub. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - Ltac add_permut_rec t := - match t with - | ?x + ?y => add_permut_rec y || add_permut_rec x - | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] - end. - - Ltac add_permut := - repeat (reflexivity || - match goal with |- ?t == _ => add_permut_rec t end). - - Ltac mul_permut_rec t := - match t with - | ?x * ?y => mul_permut_rec y || mul_permut_rec x - | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] - end. - - Ltac mul_permut := - repeat (reflexivity || - match goal with |- ?t == _ => mul_permut_rec t end). - - - Notation PExpr := (PExpr C). - Notation Pol := (Pol C). - - Implicit Types pe : PExpr. - Implicit Types P : Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match j ?= j' with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match i ?= i' with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Infix "?==" := Peq. - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj (j + j') Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P := - match j with - | xH => P - | xO j => Pinj (Pos.pred_double j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pos.pred_double j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pos.pred_double j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Infix "++" := Padd. - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Infix "--" := Psub. - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - - Infix "**" := Pmul. - - Fixpoint Psquare (P:Pol) : Pol := - match P with - | Pc c => Pc (c *! c) - | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => - let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in - let Q2 := Psquare Q in - let P2 := Psquare P in - mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 - end. - - (** Monomial **) - - (** A monomial is X1^k1...Xi^ki. Its representation - is a simplified version of the polynomial representation: - - - [mon0] correspond to the polynom [P1]. - - [(zmon j M)] corresponds to [(Pinj j ...)], - i.e. skip j variable indices. - - [(vmon i M)] is X^i*M with X the current variable, - its corresponds to (PX P1 i ...)] - *) - - Inductive Mon: Set := - | mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Pos.pred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol := - match P, M with - _, mon0 => (Pc cO, P) - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) with - Eq => let (R,S) := MFactor P1 M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 M in - let (R2, S2) := MFactor Q1 M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match (i ?= j) with - Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := - let (Q1,R1) := MFactor P1 M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Fixpoint Pphi(l:Env R) (P:Pol) : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - - (** Evaluation of a monomial towards R *) - - Fixpoint Mphi(l:Env R) (M: Mon) : R := - match M with - | mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i - end. - - Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). - - (** Proofs *) - - Ltac destr_pos_sub := - match goal with |- context [Z.pos_sub ?x ?y] => - generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - - Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. - Proof. - revert P';induction P;destruct P';simpl; intros H l; try easy. - - now apply (morph_eq CRmorph). - - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - now rewrite IHP. - - specialize (IHP1 P'1); specialize (IHP2 P'2). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - destruct (P2 ?== P'1); [|easy]. - rewrite H in *. - now rewrite IHP1, IHP2. - Qed. - - Lemma Peq_spec P P' : - BoolSpec (forall l, P@l == P'@l) True (P ?== P'). - Proof. - generalize (Peq_ok P P'). destruct (P ?== P'); auto. - Qed. - - Lemma Pphi0 l : P0@l == 0. - Proof. - simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 l : P1@l == 1. - Proof. - simpl;apply (morph1 CRmorph). - Qed. - -Lemma env_morph p e1 e2 : - (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. -Proof. - revert e1 e2. induction p ; simpl. - - reflexivity. - - intros e1 e2 EQ. apply IHp. intros. apply EQ. - - intros e1 e2 EQ. f_equal; [f_equal|]. - + now apply IHp1. - + f_equal. apply EQ. - + apply IHp2. intros; apply EQ. -Qed. - -Lemma Pjump_add P i j l : - P @ (jump (i + j) l) = P @ (jump j (jump i l)). -Proof. - apply env_morph. intros. rewrite <- jump_add. f_equal. - apply Pos.add_comm. -Qed. - -Lemma Pjump_xO_tail P p l : - P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). -Proof. - apply env_morph. intros. now jump_simpl. -Qed. - -Lemma Pjump_pred_double P p l : - P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l). -Proof. - apply env_morph. intros. - rewrite jump_pred_double. now jump_simpl. -Qed. - - Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). - Proof. - destruct P;simpl;rsimpl. - now rewrite Pjump_add. - Qed. - - Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. - Proof. - rewrite Pos.add_comm. - apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). - Qed. - - Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). - Proof. - generalize (morph_eq CRmorph c c'). - destruct (c ?=! c'); auto. - Qed. - - Lemma mkPX_ok l P i Q : - (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). - Proof. - unfold mkPX. destruct P. - - case ceqb_spec; intros H; simpl; try reflexivity. - rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - - reflexivity. - - case Peq_spec; intros H; simpl; try reflexivity. - rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. - Qed. - - Hint Rewrite - Pphi0 - Pphi1 - mkPinj_ok - mkPX_ok - (morph0 CRmorph) - (morph1 CRmorph) - (morph0 CRmorph) - (morph_add CRmorph) - (morph_mul CRmorph) - (morph_sub CRmorph) - (morph_opp CRmorph) - : Esimpl. - - (* Quicker than autorewrite with Esimpl :-) *) - Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. - - Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. - Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. - Proof. - revert l;induction P;simpl;intros. - - Esimpl. - - rewrite IHP;rsimpl. - - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. - Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. - Qed. - - Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. - Proof. - unfold PmulC. - case ceqb_spec; intros H. - - rewrite H; Esimpl. - - case ceqb_spec; intros H'. - + rewrite H'; Esimpl. - + apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok P l : (--P)@l == - P@l. - Proof. - revert l;induction P;simpl;intros. - - Esimpl. - - apply IHP. - - rewrite IHP1, IHP2;rsimpl. - Qed. - - Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. - - Lemma PaddX_ok P' P k l : - (forall P l, (P++P')@l == P@l + P'@l) -> - (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P;simpl;intros. - - add_permut. - - destruct p; simpl; - rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - - destr_pos_sub; intros ->;Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. - Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * now rewrite IHP'. - * rewrite IHP';Esimpl. now rewrite Pjump_add. - * rewrite IHP. now rewrite Pjump_add. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. - * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P;simpl. - + Esimpl. add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rewrite Pjump_xO_tail. rsimpl. add_permut. - * rewrite Pjump_pred_double. rsimpl. add_permut. - * rsimpl. unfold tail. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PaddX_ok by trivial; rsimpl. - rewrite IHP'2, pow_pos_add; rsimpl. add_permut. - Qed. - - Lemma PsubX_ok P' P k l : - (forall P l, (P--P')@l == P@l - P'@l) -> - (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P;simpl;intros. - - rewrite Popp_ok;rsimpl; add_permut. - - destruct p; simpl; - rewrite Popp_ok;rsimpl; - rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. - - destr_pos_sub; intros ->; Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. - Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * rewrite IHP';rsimpl. - * rewrite IHP';Esimpl. now rewrite Pjump_add. - * rewrite IHP. now rewrite Pjump_add. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. - * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P;simpl. - + Esimpl; add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rewrite Pjump_xO_tail. rsimpl. add_permut. - * rewrite Pjump_pred_double. rsimpl. add_permut. - * rsimpl. unfold tail. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PsubX_ok by trivial;rsimpl. - rewrite IHP'2, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma PmulI_ok P' : - (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> - forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - intros IHP'. - induction P;simpl;intros. - - Esimpl; mul_permut. - - destr_pos_sub; intros ->;Esimpl. - + now rewrite IHP'. - + now rewrite IHP', Pjump_add. - + now rewrite IHP, Pjump_add. - - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. - + rewrite Pjump_xO_tail. f_equiv. mul_permut. - + rewrite Pjump_pred_double. f_equiv. mul_permut. - + rewrite IHP'. f_equiv. mul_permut. - Qed. - - Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. - Proof. - revert P l;induction P';simpl;intros. - - apply PmulC_ok. - - apply PmulI_ok;trivial. - - destruct P. - + rewrite (ARmul_comm ARth). Esimpl. - + Esimpl. rewrite IHP'1;Esimpl. f_equiv. - destruct p0;rewrite IHP'2;Esimpl. - * now rewrite Pjump_xO_tail. - * rewrite Pjump_pred_double; Esimpl. - + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, - !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. - unfold tail. - add_permut; f_equiv; mul_permut. - Qed. - - Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. - Proof. - revert l;induction P;simpl;intros;Esimpl. - - apply IHP. - - rewrite Padd_ok, Pmul_ok;Esimpl. - rewrite IHP1, IHP2. - mul_push ((hd l)^p). now mul_push (P2@l). - Qed. - - Lemma Mphi_morph M e1 e2 : - (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. - Proof. - revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial. - - apply IHM. intros; apply EQ. - - f_equal. - * apply IHM. intros; apply EQ. - * f_equal. apply EQ. - Qed. - -Lemma Mjump_xO_tail M p l : - M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l). -Proof. - apply Mphi_morph. intros. now jump_simpl. -Qed. - -Lemma Mjump_pred_double M p l : - M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l). -Proof. - apply Mphi_morph. intros. - rewrite jump_pred_double. now jump_simpl. -Qed. - -Lemma Mjump_add M i j l : - M @@ (jump (i + j) l) = M @@ (jump j (jump i l)). -Proof. - apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm. -Qed. - - Lemma mkZmon_ok M j l : - (mkZmon j M) @@ l == (zmon j M) @@ l. - Proof. - destruct M; simpl; rsimpl. - Qed. - - Lemma zmon_pred_ok M j l : - (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. - Proof. - destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - - now rewrite Mjump_xO_tail. - - rewrite Mjump_pred_double; rsimpl. - Qed. - - Lemma mkVmon_ok M i l : - (mkVmon i M)@@l == M@@l * (hd l)^i. - Proof. - destruct M;simpl;intros;rsimpl. - - rewrite zmon_pred_ok;simpl;rsimpl. - - rewrite pow_pos_add;rsimpl. - Qed. - - Ltac destr_mfactor R S := match goal with - | H : context [MFactor ?P _] |- context [MFactor ?P ?M] => - specialize (H M); destruct MFactor as (R,S) - end. - - Lemma Mphi_ok P M l : - let (Q,R) := MFactor P M in - P@l == Q@l + M@@l * R@l. - Proof. - revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl. - - case Pos.compare_spec; intros He; simpl. - * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. - * destr_mfactor R1 S1. rewrite IHP; simpl. - now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add. - * Esimpl. - - destr_mfactor R1 S1. destr_mfactor R2 S2. - rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl. - add_permut. - - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1; - rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl; - unfold tail; add_permut; mul_permut. - * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - * rewrite mkPX_ok. simpl. Esimpl. mul_permut. - rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. - Qed. - - Lemma POneSubst_ok P1 M1 P2 P3 l : - POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l -> - P1@l == P3@l. - Proof. - unfold POneSubst. - assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H. - intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - - revert EQ. destruct S1; try now injection 1. - case ceqb_spec; now inversion 2. - Qed. - - Lemma PNSubst1_ok n P1 M1 P2 l : - M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. - Proof. - revert P1. induction n; simpl; intros P1; - generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; - intros; rewrite <- ?IHn; auto; reflexivity. - Qed. - - Lemma PNSubst_ok n P1 M1 P2 l P3 : - PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l. - Proof. - unfold PNSubst. - assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate. - destruct n; inversion_clear 1. - intros. rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop := - match LM1 with - | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l - | _ => True - end. - - Lemma PSubstL1_ok n LM1 P1 l : - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition. now apply PNSubst1_ok. - Qed. - - Lemma PSubstL_ok n LM1 P1 P2 l : - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - - discriminate. - - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. - * now apply IH. - Qed. - - Lemma PNSubstL_ok m n LM1 P1 l : - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - revert LM1 P1. induction m; simpl; intros; - assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; - auto; try reflexivity. - rewrite <- IHm; auto. - Qed. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:Env R) (pe:PExpr) : R := - match pe with - | PEc c => phi c - | PEX j => nth j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - - (** Correctness proofs *) - - Lemma mkX_ok p l : nth p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - rewrite nth_spec ; auto. - unfold hd. - now rewrite <- nth_pred_double, nth_jump. - Qed. - - Hint Rewrite Padd_ok Psub_ok : Esimpl. - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := - match p with - | xH => subst_l (res ** P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok l : - (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros subst_l_ok res P p. revert res. - induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; - mul_permut. - Qed. - - Lemma Ppow_N_ok l : - (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. - destruct n;simpl. - - reflexivity. - - rewrite Ppow_pos_ok by trivial. Esimpl. - Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (** Internally, [norm_aux] is expanded in a large number of cases. - To speed-up proofs, we use an alternative definition. *) - - Definition get_PEopp pe := - match pe with - | PEopp pe' => Some pe' - | _ => None - end. - - Lemma norm_aux_PEadd pe1 pe2 : - norm_aux (PEadd pe1 pe2) = - match get_PEopp pe1, get_PEopp pe2 with - | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') - | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') - | None, None => (norm_aux pe1) ++ (norm_aux pe2) - end. - Proof. - simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | reflexivity | ]; - destruct pe2; simpl get_PEopp; reflexivity. - Qed. - - Lemma norm_aux_PEopp pe : - match get_PEopp pe with - | Some pe' => norm_aux pe = -- (norm_aux pe') - | None => True - end. - Proof. - now destruct pe. - Qed. - - Lemma norm_aux_spec l pe : - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe. - - reflexivity. - - apply mkX_ok. - - simpl PEeval. rewrite IHpe1, IHpe2. - assert (H1 := norm_aux_PEopp pe1). - assert (H2 := norm_aux_PEopp pe2). - rewrite norm_aux_PEadd. - do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - - simpl. rewrite IHpe1, IHpe2. Esimpl. - - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - - simpl. rewrite IHpe. Esimpl. - - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. - induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. - Qed. - - End NORM_SUBST_REC. - -End MakeRingPol. diff --git a/plugins/micromega/Fourier.v b/plugins/micromega/Fourier.v deleted file mode 100644 index 0153de1dab..0000000000 --- a/plugins/micromega/Fourier.v +++ /dev/null @@ -1,5 +0,0 @@ -Require Import Lra. -Require Export Fourier_util. - -#[deprecated(since = "8.9.0", note = "Use lra instead.")] -Ltac fourier := lra. diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v deleted file mode 100644 index 95fa5b88df..0000000000 --- a/plugins/micromega/Fourier_util.v +++ /dev/null @@ -1,31 +0,0 @@ -Require Export Rbase. -Require Import Lra. - -Local Open Scope R_scope. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -apply Rmult_lt_compat_l; auto with real. -ring. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rle_lt_0_plus_1. -red; auto with real. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. - intros; lra. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -red; left. -apply Rlt_mult_inv_pos; auto with real. -rewrite <- H1. -red; right; ring. -Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v deleted file mode 100644 index e53800d07d..0000000000 --- a/plugins/micromega/Lia.v +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2013-2016 *) -(* *) -(************************************************************************) - -Require Import ZMicromega. -Require Import ZArith_base. -Require Import RingMicromega. -Require Import VarMap. -Require Import DeclConstant. -Require Coq.micromega.Tauto. -Declare ML Module "micromega_plugin". - - -Ltac zchecker := - intros __wit __varmap __ff ; - exact (ZTautoChecker_sound __ff __wit - (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) - (@find Z Z0 __varmap)). - -Ltac lia := PreOmega.zify; xlia zchecker. - -Ltac nia := PreOmega.zify; xnlia zchecker. - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v deleted file mode 100644 index 25fb62cfad..0000000000 --- a/plugins/micromega/Lqa.v +++ /dev/null @@ -1,54 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2016 *) -(* *) -(************************************************************************) - -Require Import QMicromega. -Require Import QArith. -Require Import RingMicromega. -Require Import VarMap. -Require Import DeclConstant. -Require Coq.micromega.Tauto. -Declare ML Module "micromega_plugin". - -Ltac rchange := - intros __wit __varmap __ff ; - change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit). - -Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. -Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true). - -Ltac rchecker := rchecker_no_abstract. - -(** Here, lra stands for linear rational arithmetic *) -Ltac lra := lra_Q rchecker. - -(** Here, nra stands for non-linear rational arithmetic *) -Ltac nra := xnqa rchecker. - -Ltac xpsatz dom d := - let tac := lazymatch dom with - | Q => - ((sos_Q rchecker) || (psatz_Q d rchecker)) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v deleted file mode 100644 index 2403696696..0000000000 --- a/plugins/micromega/Lra.v +++ /dev/null @@ -1,54 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2016 *) -(* *) -(************************************************************************) - -Require Import RMicromega. -Require Import QMicromega. -Require Import Rdefinitions. -Require Import RingMicromega. -Require Import VarMap. -Require Coq.micromega.Tauto. -Declare ML Module "micromega_plugin". - -Ltac rchange := - intros __wit __varmap __ff ; - change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit). - -Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. -Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true). - -Ltac rchecker := rchecker_no_abstract. - -(** Here, lra stands for linear real arithmetic *) -Ltac lra := unfold Rdiv in * ; lra_R rchecker. - -(** Here, nra stands for non-linear real arithmetic *) -Ltac nra := unfold Rdiv in * ; xnra rchecker. - -Ltac xpsatz dom d := - let tac := lazymatch dom with - | R => - (sos_R rchecker) || (psatz_R d rchecker) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v deleted file mode 100644 index 0e8c09ef1b..0000000000 --- a/plugins/micromega/MExtraction.v +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -(* Used to generate micromega.ml *) - -Require Extraction. -Require Import ZMicromega. -Require Import QMicromega. -Require Import RMicromega. -Require Import VarMap. -Require Import RingMicromega. -Require Import NArith. -Require Import QArith. - -Extract Inductive prod => "( * )" [ "(,)" ]. -Extract Inductive list => list [ "[]" "(::)" ]. -Extract Inductive bool => bool [ true false ]. -Extract Inductive sumbool => bool [ true false ]. -Extract Inductive option => option [ Some None ]. -Extract Inductive sumor => option [ Some None ]. -(** Then, in a ternary alternative { }+{ }+{ }, - - leftmost choice (Inleft Left) is (Some true), - - middle choice (Inleft Right) is (Some false), - - rightmost choice (Inright) is (None) *) - - -(** To preserve its laziness, andb is normally expanded. - Let's rather use the ocaml && *) -Extract Inlined Constant andb => "(&&)". - -Import Reals.Rdefinitions. - -Extract Constant R => "int". -Extract Constant R0 => "0". -Extract Constant R1 => "1". -Extract Constant Rplus => "( + )". -Extract Constant Rmult => "( * )". -Extract Constant Ropp => "fun x -> - x". -Extract Constant Rinv => "fun x -> 1 / x". - -(** In order to avoid annoying build dependencies the actual - extraction is only performed as a test in the test suite. *) -(*Extraction "micromega.ml" - Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - Tauto.abst_form - ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ - List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add - normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. -*) -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v deleted file mode 100644 index d5884d9c1c..0000000000 --- a/plugins/micromega/OrderedRing.v +++ /dev/null @@ -1,460 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import Setoid. -Require Import Ring. - -(** Generic properties of ordered rings on a setoid equality *) - -Set Implicit Arguments. - -Module Import OrderedRingSyntax. -Export RingSyntax. - -Reserved Notation "x ~= y" (at level 70, no associativity). -Reserved Notation "x [=] y" (at level 70, no associativity). -Reserved Notation "x [~=] y" (at level 70, no associativity). -Reserved Notation "x [<] y" (at level 70, no associativity). -Reserved Notation "x [<=] y" (at level 70, no associativity). -End OrderedRingSyntax. - -Section DEFINITIONS. - -Variable R : Type. -Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Record SOR : Type := mk_SOR_theory { - SORsetoid : Setoid_Theory R req; - SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; - SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); - SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); - SORrt : ring_theory rO rI rplus rtimes rminus ropp req; - SORle_refl : forall n : R, n <= n; - SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; - SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; - SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; - SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; - SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; - SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; - SORneq_0_1 : 0 ~= 1 -}. - -(* We cannot use Relation_Definitions.order.ord_antisym and -Relations_1.Antisymmetric because they refer to Leibniz equality *) - -End DEFINITIONS. - -Section STRICT_ORDERED_RING. - -Variable R : Type. -Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as sor_setoid. - - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact (SORlt_wd sor). -Qed. - -Add Ring SOR : (SORrt sor). - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. -intros x1 x2 H1 y1 y2 H2. -rewrite ((Rsub_def (SORrt sor)) x1 y1). -rewrite ((Rsub_def (SORrt sor)) x2 y2). -rewrite H1; now rewrite H2. -Qed. - -Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. -Proof. -intros n m H1 H2; rewrite H2 in H1; now apply H1. -Qed. - -(* Properties of plus, minus and opp *) - -Theorem Rplus_0_l : forall n : R, 0 + n == n. -Proof. -intro; ring. -Qed. - -Theorem Rplus_0_r : forall n : R, n + 0 == n. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_0_r : forall n : R, n * 0 == 0. -Proof. -intro; ring. -Qed. - -Theorem Rplus_comm : forall n m : R, n + m == m + n. -Proof. -intros; ring. -Qed. - -Theorem Rtimes_0_l : forall n : R, 0 * n == 0. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_comm : forall n m : R, n * m == m * n. -Proof. -intros; ring. -Qed. - -Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. -Proof. -intros n m. -split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. -now rewrite Rplus_0_l. -rewrite H; ring. -Qed. - -Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. -Proof. -intros n m p; split; intro H. -setoid_replace n with (- p + (p + n)) by ring. -setoid_replace m with (- p + (p + m)) by ring. now rewrite H. -now rewrite H. -Qed. - -(* Relations *) - -Theorem Rle_refl : forall n : R, n <= n. -Proof (SORle_refl sor). - -Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof (SORle_antisymm sor). - -Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof (SORle_trans sor). - -Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof (SORlt_trichotomy sor). - -Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof (SORlt_le_neq sor). - -Theorem Rneq_0_1 : 0 ~= 1. -Proof (SORneq_0_1 sor). - -Theorem Req_em : forall n m : R, n == m \/ n ~= m. -Proof. -intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. -right; now destruct H. -now left. -right; apply Rneq_symm; now destruct H. -Qed. - -Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. -Proof. -intros n m; destruct (Req_em n m) as [H | H]. -split; auto. -split. intro H1; false_hyp H H1. auto. -Qed. - -Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. -Proof. -intros n m; rewrite Rlt_le_neq. -split; [intro H | intros [[H1 H2] | H]]. -destruct (Req_em n m) as [H1 | H1]. now right. left; now split. -assumption. -rewrite H; apply Rle_refl. -Qed. - -Ltac le_less := rewrite Rle_lt_eq; left; try assumption. -Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. -Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. - -Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. -Proof. -intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. -now apply Rle_trans with m. -intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. -Qed. - -Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. -Proof. -intros n m p H1 H2; le_elim H1. -now apply Rlt_trans with (m := m). now rewrite H1. -Qed. - -Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. -Proof. -intros n m p H1 H2; le_elim H2. -now apply Rlt_trans with (m := m). now rewrite <- H2. -Qed. - -Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. -Proof. -intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. -left; now le_less. left; now le_equal. now right. -Qed. - -Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. -Proof. -intros n m; rewrite Rlt_le_neq; now intros [_ H]. -Qed. - -Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. -Proof. -intros n m; split. -intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). -intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. -Qed. - -Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. -Proof. -intros n m; split. -intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). -intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. -Qed. - -(* Plus, minus and order *) - -Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. -Proof. -intros n m p; split. -apply (SORplus_le_mono_l sor). -intro H. apply ((SORplus_le_mono_l sor) (p + n) (p + m) (- p)) in H. -setoid_replace (- p + (p + n)) with n in H by ring. -setoid_replace (- p + (p + m)) with m in H by ring. assumption. -Qed. - -Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. -Proof. -intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). -apply Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. -Proof. -intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. -now rewrite <- Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. -Proof. -intros n m p. -rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. -Qed. - -Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. -Proof. -intros n m p q H1 H2. -apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. -Qed. - -Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. -Qed. - -Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. -Qed. - -Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. -Qed. - -Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. -Proof. -intros n m. rewrite (@Rplus_le_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. -Proof. -intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. -Proof. -intros n m. split; intro H. -apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. -setoid_replace (- n - m + n) with (- m) in H by ring. -now setoid_replace (- n - m + m) with (- n) in H by ring. -apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. -setoid_replace (n + m + - m) with n in H by ring. -now setoid_replace (n + m + - n) with m in H by ring. -Qed. - -Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. -Proof. -intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. -Qed. - -(* Times and order *) - -Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof (SORtimes_pos_pos sor). - -Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. -Proof. -intros n m H1 H2. -le_elim H1. le_elim H2. -le_less; now apply Rtimes_pos_pos. -rewrite <- H2; rewrite Rtimes_0_r; le_equal. -rewrite <- H1; rewrite Rtimes_0_l; le_equal. -Qed. - -Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. -Proof. -intros n m H1 H2. apply -> Ropp_pos_neg. -setoid_replace (- (n * m)) with (n * (- m)) by ring. -apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. -Proof. -intros n m H1 H2. -setoid_replace (n * m) with ((- n) * (- m)) by ring. -apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. -Proof. -intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. -le_less; now apply Rtimes_pos_pos. -rewrite <- H, Rtimes_0_l; le_equal. -le_less; now apply Rtimes_neg_neg. -Qed. - -Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. -Proof. -intros n m [H1 H2]. -destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; -destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; -try (false_hyp H3 H1); try (false_hyp H4 H2). -apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. -apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. -apply Rlt_neq. now apply Rtimes_pos_neg. -apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. -Qed. - -(* The following theorems are used to build a morphism from Z to R and -prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) - -(* Surprisingly, multilication is needed to prove the following theorem *) - -Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. -Proof. -intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. -now setoid_replace (- - n) with n by ring. -Qed. - -Theorem Rlt_0_1 : 0 < 1. -Proof. -apply <- Rlt_le_neq. split. -setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. -apply Rneq_0_1. -Qed. - -Theorem Rlt_succ_r : forall n : R, n < 1 + n. -Proof. -intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. -apply -> Rplus_lt_mono_r. apply Rlt_0_1. -Qed. - -Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. -Proof. -intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. -Qed. - -(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. -Proof. -intros n m p H1 H2. apply <- Rlt_lt_minus. -setoid_replace (p * m - p * n) with (p * (m - n)) by ring. -apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. -Qed.*) - -End STRICT_ORDERED_RING. - diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v deleted file mode 100644 index 16ae24ba81..0000000000 --- a/plugins/micromega/Psatz.v +++ /dev/null @@ -1,68 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2016 *) -(* *) -(************************************************************************) - -Require Import ZMicromega. -Require Import QMicromega. -Require Import RMicromega. -Require Import QArith. -Require Import ZArith. -Require Import Rdefinitions. -Require Import RingMicromega. -Require Import VarMap. -Require Coq.micromega.Tauto. -Require Lia. -Require Lra. -Require Lqa. - -Declare ML Module "micromega_plugin". - -Ltac lia := Lia.lia. - -Ltac nia := Lia.nia. - - -Ltac xpsatz dom d := - let tac := lazymatch dom with - | Z => - (sos_Z Lia.zchecker) || (psatz_Z d Lia.zchecker) - | R => - (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker) - | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). - -Ltac psatzl dom := - let tac := lazymatch dom with - | Z => Lia.lia - | Q => Lqa.lra - | R => Lra.lra - | _ => fail "Unsupported domain" - end in tac. - - -Ltac lra := - first [ psatzl R | psatzl Q ]. - -Ltac nra := - first [ Lra.nra | Lqa.nra ]. - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v deleted file mode 100644 index 4a02d1d01e..0000000000 --- a/plugins/micromega/QMicromega.v +++ /dev/null @@ -1,220 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import Refl. -Require Import QArith. -Require Import Qfield. -(*Declare ML Module "micromega_plugin".*) - -Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt. -Proof. - constructor; intros ; subst ; try (intuition (subst; auto with qarith)). - apply Q_Setoid. - rewrite H ; rewrite H0 ; reflexivity. - rewrite H ; rewrite H0 ; reflexivity. - rewrite H ; auto ; reflexivity. - rewrite <- H ; rewrite <- H0 ; auto. - rewrite H ; rewrite H0 ; auto. - rewrite <- H ; rewrite <- H0 ; auto. - rewrite H ; rewrite H0 ; auto. - apply Qsrt. - eapply Qle_trans ; eauto. - apply (Qlt_not_eq n m H H0) ; auto. - destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto. - apply (Qplus_le_compat p p n m (Qle_refl p) H). - generalize (Qmult_lt_compat_r 0 n m H0 H). - rewrite Qmult_0_l. - auto. - compute in H. - discriminate. -Qed. - - -Lemma QSORaddon : - SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *) - 0 1 Qplus Qmult Qminus Qopp (* coefficients *) - Qeq_bool Qle_bool - (fun x => x) (fun x => x) (pow_N 1 Qmult). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Qeq_bool_eq; auto. - constructor. - reflexivity. - intros x y. - apply Qeq_bool_neq ; auto. - apply Qle_bool_imp_le. -Qed. - - -(*Definition Zeval_expr := eval_pexpr 0 Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => Z.of_N x) (Z.pow).*) -Require Import EnvRing. - -Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) - end. - -Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) - end. -Proof. - destruct e ; reflexivity. -Qed. - -Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n. -Proof. - destruct n ; reflexivity. -Qed. - - -Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. -Proof. - induction e ; simpl ; subst ; try congruence. - reflexivity. - rewrite IHe. - apply QNpower. -Qed. - -Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := -match o with -| OpEq => Qeq -| OpNEq => fun x y => ~ x == y -| OpLe => Qle -| OpGe => fun x y => Qle y x -| OpLt => Qlt -| OpGt => fun x y => Qlt y x -end. - -Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := - let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). - -Definition Qeval_formula' := - eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. -Proof. - intros. - unfold Qeval_formula. - destruct f. - repeat rewrite Qeval_expr_compat. - unfold Qeval_formula'. - unfold Qeval_expr'. - split ; destruct Fop ; simpl; auto. -Qed. - - -Definition Qeval_nformula := - eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) . - -Definition Qeval_op1 (o : Op1) : Q -> Prop := -match o with -| Equal => fun x : Q => x == 0 -| NonEqual => fun x : Q => ~ x == 0 -| Strict => fun x : Q => 0 < x -| NonStrict => fun x : Q => 0 <= x -end. - - -Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). -Qed. - -Definition QWitness := Psatz Q. - -Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. - -Require Import List. - -Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), - QWeakChecker l cm = true -> - forall env, make_impl (Qeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Qeval_nformula. - apply (checker_nf_sound Qsor QSORaddon l cm). - unfold QWeakChecker in H. - exact H. -Qed. - -Require Import Coq.micromega.Tauto. - -Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. - -Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. - -Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. -Declare Equivalent Keys normQ RingMicromega.norm. - -Definition cnfQ (Annot TX AF: Type) (f: TFormula (Formula Q) Annot TX AF) := - rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. - -Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) unit - qunsat qdeduce - (Qnormalise unit) - (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w. - - - -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. -Proof. - intros f w. - unfold QTautoChecker. - apply tauto_checker_sound with (eval:= Qeval_formula) (eval':= Qeval_nformula). - - apply Qeval_nformula_dec. - - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - - unfold qdeduce. intros. revert H. apply (nformula_plus_nformula_correct Qsor QSORaddon);auto. - - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. - - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. - - intros t w0. - unfold eval_tt. - intros. - rewrite make_impl_map with (eval := Qeval_nformula env). - eapply QWeakChecker_sound; eauto. - tauto. -Qed. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v deleted file mode 100644 index 0f7a02c2c9..0000000000 --- a/plugins/micromega/RMicromega.v +++ /dev/null @@ -1,489 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import Refl. -Require Import Raxioms Rfunctions RIneq Rpow_def. -Require Import QArith. -Require Import Qfield. -Require Import Qreals. -Require Import DeclConstant. -Require Import Ztac. - -Require Setoid. -(*Declare ML Module "micromega_plugin".*) - -Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R). -Proof. - constructor. - exact Rplus_0_l. - exact Rplus_comm. - intros. rewrite Rplus_assoc. auto. - exact Rmult_1_l. - exact Rmult_comm. - intros ; rewrite Rmult_assoc ; auto. - intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l. - rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto. - reflexivity. - exact Rplus_opp_r. -Qed. - -Local Open Scope R_scope. - -Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. -Proof. - constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). - constructor. - constructor. - unfold RelationClasses.Symmetric. auto. - unfold RelationClasses.Transitive. intros. subst. reflexivity. - apply Rsrt. - eapply Rle_trans ; eauto. - apply (Rlt_irrefl m) ; auto. - apply Rnot_le_lt. auto with real. - destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - now apply Rmult_lt_0_compat. -Qed. - -Lemma Rinv_1 : forall x, x * / 1 = x. -Proof. - intro. - rewrite Rinv_1. - apply Rmult_1_r. -Qed. - -Lemma Qeq_true : forall x y, Qeq_bool x y = true -> Q2R x = Q2R y. -Proof. - intros. - now apply Qeq_eqR, Qeq_bool_eq. -Qed. - -Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y. -Proof. - intros. - apply Qeq_bool_neq in H. - contradict H. - now apply eqR_Qeq. -Qed. - -Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y. -Proof. - intros. - now apply Qle_Rle, Qle_bool_imp_le. -Qed. - -Lemma Q2R_0 : Q2R 0 = 0. -Proof. - apply Rmult_0_l. -Qed. - -Lemma Q2R_1 : Q2R 1 = 1. -Proof. - compute. apply Rinv_1. -Qed. - -Lemma Q2R_inv_ext : forall x, - Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x). -Proof. - intros. - case_eq (Qeq_bool x 0). - intros. - apply Qeq_bool_eq in H. - destruct x ; simpl. - unfold Qeq in H. - simpl in H. - rewrite Zmult_1_r in H. - rewrite H. - apply Rmult_0_l. - intros. - now apply Q2R_inv, Qeq_bool_neq. -Qed. - -Notation to_nat := N.to_nat. - -Lemma QSORaddon : - @SORaddon R - R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) - Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) - Qeq_bool Qle_bool - Q2R nat to_nat pow. -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Q2R_0. - apply Q2R_1. - apply Q2R_plus. - apply Q2R_minus. - apply Q2R_mult. - apply Q2R_opp. - apply Qeq_true ; auto. - apply R_power_theory. - apply Qeq_false. - apply Qle_true. -Qed. - -(* Syntactic ring coefficients. *) - -Inductive Rcst := - | C0 - | C1 - | CQ (r : Q) - | CZ (r : Z) - | CPlus (r1 r2 : Rcst) - | CMinus (r1 r2 : Rcst) - | CMult (r1 r2 : Rcst) - | CPow (r1 : Rcst) (z:Z+nat) - | CInv (r : Rcst) - | COpp (r : Rcst). - - - -Definition z_of_exp (z : Z + nat) := - match z with - | inl z => z - | inr n => Z.of_nat n - end. - -Fixpoint Q_of_Rcst (r : Rcst) : Q := - match r with - | C0 => 0 # 1 - | C1 => 1 # 1 - | CZ z => z # 1 - | CQ q => q - | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) - | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) - | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) - | CPow r1 z => Qpower (Q_of_Rcst r1) (z_of_exp z) - | CInv r => Qinv (Q_of_Rcst r) - | COpp r => Qopp (Q_of_Rcst r) - end. - - -Definition is_neg (z: Z+nat) := - match z with - | inl (Zneg _) => true - | _ => false - end. - -Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z. -Proof. - destruct z ; simpl ; try congruence. - destruct z ; try congruence. - intros. - reflexivity. -Qed. - -Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z. -Proof. - destruct z ; simpl ; try congruence. - destruct z ; try congruence. - compute. congruence. - compute. congruence. - generalize (Zle_0_nat n). auto using Z.le_ge. -Qed. - -Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). - -Definition CPowR0 (z : Z) (r : Rcst) := - Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1). - -Fixpoint R_of_Rcst (r : Rcst) : R := - match r with - | C0 => R0 - | C1 => R1 - | CZ z => IZR z - | CQ q => Q2R q - | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) - | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) - | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) - | CPow r1 z => - match z with - | inl z => - if CPowR0 z r1 - then R0 - else powerRZ (R_of_Rcst r1) z - | inr n => pow (R_of_Rcst r1) n - end - | CInv r => - if CInvR0 r then R0 - else Rinv (R_of_Rcst r) - | COpp r => - (R_of_Rcst r) - end. - -Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m. - exact Qeq_eqR. -Qed. - -Lemma Q2R_pow_pos : forall q p, - Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p. -Proof. - induction p ; simpl;auto; - rewrite <- IHp; - repeat rewrite Q2R_mult; - reflexivity. -Qed. - -Lemma Q2R_pow_N : forall q n, - Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n. -Proof. - destruct n ; simpl. - - apply Q2R_1. - - apply Q2R_pow_pos. -Qed. - -Lemma Qmult_integral : forall q r, q * r == 0 -> q == 0 \/ r == 0. -Proof. - intros. - destruct (Qeq_dec q 0)%Q. - - left ; apply q0. - - apply Qmult_integral_l in H ; tauto. -Qed. - -Lemma Qpower_positive_eq_zero : forall q p, - Qpower_positive q p == 0 -> q == 0. -Proof. - unfold Qpower_positive. - induction p ; simpl; intros; - repeat match goal with - | H : _ * _ == 0 |- _ => - apply Qmult_integral in H; destruct H - end; tauto. -Qed. - -Lemma Qpower_positive_zero : forall p, - Qpower_positive 0 p == 0%Q. -Proof. - induction p ; simpl; - try rewrite IHp ; reflexivity. -Qed. - - -Lemma Q2RpowerRZ : - forall q z - (DEF : not (q == 0)%Q \/ (z >= Z0)%Z), - Q2R (q ^ z) = powerRZ (Q2R q) z. -Proof. - intros. - destruct Qpower_theory. - destruct R_power_theory. - unfold Qpower, powerRZ. - destruct z. - - apply Q2R_1. - - - change (Qpower_positive q p) - with (Qpower q (Zpos p)). - rewrite <- N2Z.inj_pos. - rewrite <- positive_N_nat. - rewrite rpow_pow_N. - rewrite rpow_pow_N0. - apply Q2R_pow_N. - - - rewrite Q2R_inv. - unfold Qpower_positive. - rewrite <- positive_N_nat. - rewrite rpow_pow_N0. - unfold pow_N. - rewrite Q2R_pow_pos. - auto. - intro. - apply Qpower_positive_eq_zero in H. - destruct DEF ; auto with arith. -Qed. - -Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q. -Proof. - unfold Qpower. - destruct z;intros. - - congruence. - - apply Qpower_positive_zero. - - rewrite Qpower_positive_zero. - reflexivity. -Qed. - - -Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c. -Proof. - induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). - - apply Q2R_0. - - apply Q2R_1. - - reflexivity. - - unfold Q2R. simpl. rewrite Rinv_1. reflexivity. - - apply Q2R_plus. - - apply Q2R_minus. - - apply Q2R_mult. - - destruct z. - destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C. - + - rewrite andb_true_iff in C. - destruct C as (C1 & C2). - rewrite Z.ltb_lt in C1. - apply Qeq_bool_eq in C2. - rewrite C2. - simpl. - rewrite Qpower0. - apply Q2R_0. - intro ; subst ; slia C1 C1. - + rewrite Q2RpowerRZ. - rewrite IHc. - reflexivity. - rewrite andb_false_iff in C. - destruct C. - simpl. apply Z.ltb_ge in H. - right ; normZ. slia H H0. - left ; apply Qeq_bool_neq; auto. - + simpl. - rewrite <- IHc. - destruct Qpower_theory. - rewrite <- nat_N_Z. - rewrite rpow_pow_N. - destruct R_power_theory. - rewrite <- (Nnat.Nat2N.id n) at 2. - rewrite rpow_pow_N0. - apply Q2R_pow_N. - - rewrite <- IHc. - unfold CInvR0. - apply Q2R_inv_ext. - - rewrite <- IHc. - apply Q2R_opp. -Qed. - -Require Import EnvRing. - -Definition INZ (n:N) : R := - match n with - | N0 => IZR 0%Z - | Npos p => IZR (Zpos p) - end. - -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. - - -Definition Reval_op2 (o:Op2) : R -> R -> Prop := - match o with - | OpEq => @eq R - | OpNEq => fun x y => ~ x = y - | OpLe => Rle - | OpGe => Rge - | OpLt => Rlt - | OpGt => Rgt - end. - - -Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) := - let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). - - -Definition Reval_formula' := - eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. - -Definition QReval_formula := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow . - -Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. -Proof. - intros. - unfold Reval_formula. - destruct f. - unfold Reval_formula'. - unfold Reval_expr. - split ; destruct Fop ; simpl ; auto. - apply Rge_le. - apply Rle_ge. -Qed. - -Definition Qeval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt Q2R. - - -Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Rsor Q2R env d). -Qed. - -Definition RWitness := Psatz Q. - -Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. - -Require Import List. - -Lemma RWeakChecker_sound : forall (l : list (NFormula Q)) (cm : RWitness), - RWeakChecker l cm = true -> - forall env, make_impl (Qeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Qeval_nformula. - apply (checker_nf_sound Rsor QSORaddon l cm). - unfold RWeakChecker in H. - exact H. -Qed. - -Require Import Coq.micromega.Tauto. - -Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. -Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. - -Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. - -Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) - unit runsat rdeduce - (Rnormalise unit) (Rnegate unit) - RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst) f) w. - -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. -Proof. - intros f w. - unfold RTautoChecker. - intros TC env. - apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. - - change (eval_f (fun x : Prop => x) (QReval_formula env)) - with - (eval_bf (QReval_formula env)) in TC. - rewrite eval_bf_map in TC. - unfold eval_bf in TC. - rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. - intro. - unfold QReval_formula. - rewrite <- eval_formulaSC with (phiS := R_of_Rcst). - rewrite Reval_formula_compat. - tauto. - intro. rewrite Q_of_RcstR. reflexivity. - - - apply Reval_nformula_dec. - - destruct t. - apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - - unfold rdeduce. - intros. revert H. - eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto. - - now apply (cnf_normalise_correct Rsor QSORaddon). - - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. - - intros t w0. - unfold eval_tt. - intros. - rewrite make_impl_map with (eval := Qeval_nformula env0). - eapply RWeakChecker_sound; eauto. - tauto. -Qed. - - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v deleted file mode 100644 index cd759029fa..0000000000 --- a/plugins/micromega/Refl.v +++ /dev/null @@ -1,152 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import List. -Require Setoid. - -Set Implicit Arguments. - -(* Refl of '->' '/\': basic properties *) - -Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := - match l with - | nil => goal - | cons e l => (eval e) -> (make_impl eval l goal) - end. - -Theorem make_impl_true : - forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. -Proof. -induction l as [| a l IH]; simpl. -trivial. -intro; apply IH. -Qed. - - -Theorem make_impl_map : - forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r - (EVAL : forall x, eval' x <-> eval (fst x)), - make_impl eval' l r <-> make_impl eval (List.map fst l) r. -Proof. -induction l as [| a l IH]; simpl. -- tauto. -- intros. - rewrite EVAL. - rewrite IH. - tauto. - auto. -Qed. - -Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := - match l with - | nil => True - | cons e nil => (eval e) - | cons e l2 => ((eval e) /\ (make_conj eval l2)) - end. - -Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), - make_conj eval (a :: l) <-> eval a /\ make_conj eval l. -Proof. -intros; destruct l; simpl; tauto. -Qed. - - -Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), - (make_conj eval l -> g) <-> make_impl eval l g. -Proof. - induction l. - simpl. - tauto. - simpl. - intros. - destruct l. - simpl. - tauto. - generalize (IHl g). - tauto. -Qed. - -Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), - make_conj eval l -> (forall p, In p l -> eval p). -Proof. - induction l. - simpl. - tauto. - simpl. - intros. - destruct l. - simpl in H0. - destruct H0. - subst; auto. - tauto. - destruct H. - destruct H0. - subst;auto. - apply IHl; auto. -Qed. - -Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. -Proof. - induction l1. - simpl. - tauto. - intros. - change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). - rewrite make_conj_cons. - rewrite IHl1. - rewrite make_conj_cons. - tauto. -Qed. - -Infix "+++" := rev_append (right associativity, at level 60) : list_scope. - -Lemma make_conj_rapp : forall A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2). -Proof. - induction l1. - - simpl. tauto. - - intros. - simpl rev_append at 1. - rewrite IHl1. - rewrite make_conj_app. - rewrite make_conj_cons. - simpl app. - rewrite make_conj_cons. - rewrite make_conj_app. - tauto. -Qed. - -Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), - ~ make_conj eval (t ::a) <-> ~ (eval t) \/ (~ make_conj eval a). -Proof. - intros. - rewrite make_conj_cons. - tauto. -Qed. - -Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval - (no_middle_eval : forall d, eval d \/ ~ eval d) , - ~ make_conj eval (t ++ a) <-> (~ make_conj eval t) \/ (~ make_conj eval a). -Proof. - induction t. - - simpl. - tauto. - - intros. - simpl ((a::t)++a0). - rewrite !not_make_conj_cons by auto. - rewrite IHt by auto. - tauto. -Qed. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v deleted file mode 100644 index aa8876357a..0000000000 --- a/plugins/micromega/RingMicromega.v +++ /dev/null @@ -1,1134 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import NArith. -Require Import Relation_Definitions. -Require Import Setoid. -(*****) -Require Import Env. -Require Import EnvRing. -(*****) -Require Import List. -Require Import Bool. -Require Import OrderedRing. -Require Import Refl. -Require Coq.micromega.Tauto. - -Set Implicit Arguments. - -Import OrderedRingSyntax. - -Section Micromega. - -(* Assume we have a strict(ly?) ordered ring *) - -Variable R : Type. -Variables rO rI : R. -Variables rplus rtimes rminus: R -> R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -(* Assume we have a type of coefficients C and a morphism from C to R *) - -Variable C : Type. -Variables cO cI : C. -Variables cplus ctimes cminus: C -> C -> C. -Variable copp : C -> C. -Variables ceqb cleb : C -> C -> bool. -Variable phi : C -> R. - -(* Power coefficients *) -Variable E : Type. (* the type of exponents *) -Variable pow_phi : N -> E. -Variable rpow : R -> E -> R. - -Notation "[ x ]" := (phi x). -Notation "x [=] y" := (ceqb x y). -Notation "x [<=] y" := (cleb x y). - -(* Let's collect all hypotheses in addition to the ordered ring axioms into -one structure *) - -Record SORaddon := mk_SOR_addon { - SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; - SORpower : power_theory rI rtimes req pow_phi rpow; - SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; - SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] -}. - -Variable addon : SORaddon. - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as micomega_sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. - exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. - exact (SORlt_wd sor). -Qed. - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) -Qed. - -Definition cneqb (x y : C) := negb (ceqb x y). -Definition cltb (x y : C) := (cleb x y) && (cneqb x y). - -Notation "x [~=] y" := (cneqb x y). -Notation "x [<] y" := (cltb x y). - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. -Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. - -Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. -Proof. - exact (SORcleb_morph addon). -Qed. - -Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. -Proof. -intros x y H1. apply (SORcneqb_morph addon). unfold cneqb, negb in H1. -destruct (ceqb x y); now try discriminate. -Qed. - - -Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. -Proof. -intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. -apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. -Qed. - -(* Begin Micromega *) - -Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) -Definition PolEnv := Env R. (* For interpreting PolC *) -Definition eval_pol : PolEnv -> PolC -> R := - Pphi rplus rtimes phi. - -Inductive Op1 : Set := (* relations with 0 *) -| Equal (* == 0 *) -| NonEqual (* ~= 0 *) -| Strict (* > 0 *) -| NonStrict (* >= 0 *). - -Definition NFormula := (PolC * Op1)%type. (* normalized formula *) - -Definition eval_op1 (o : Op1) : R -> Prop := -match o with -| Equal => fun x => x == 0 -| NonEqual => fun x : R => x ~= 0 -| Strict => fun x : R => 0 < x -| NonStrict => fun x : R => 0 <= x -end. - -Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := -let (p, op) := f in eval_op1 op (eval_pol env p). - - -(** Rule of "signs" for addition and multiplication. - An arbitrary result is coded buy None. *) - -Definition OpMult (o o' : Op1) : option Op1 := -match o with -| Equal => Some Equal -| NonStrict => - match o' with - | Equal => Some Equal - | NonEqual => None - | Strict => Some NonStrict - | NonStrict => Some NonStrict - end -| Strict => match o' with - | NonEqual => None - | _ => Some o' - end -| NonEqual => match o' with - | Equal => Some Equal - | NonEqual => Some NonEqual - | _ => None - end -end. - -Definition OpAdd (o o': Op1) : option Op1 := - match o with - | Equal => Some o' - | NonStrict => - match o' with - | Strict => Some Strict - | NonEqual => None - | _ => Some NonStrict - end - | Strict => match o' with - | NonEqual => None - | _ => Some Strict - end - | NonEqual => match o' with - | Equal => Some NonEqual - | _ => None - end - end. - - -Lemma OpMult_sound : - forall (o o' om: Op1) (x y : R), - eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). -Proof. -unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. -(* x == 0 *) -inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). -(* x ~= 0 *) -destruct o' ; inversion H3. - (* y == 0 *) - rewrite H2. now rewrite (Rtimes_0_r sor). - (* y ~= 0 *) - apply (Rtimes_neq_0 sor) ; auto. -(* 0 < x *) -destruct o' ; inversion H3. - (* y == 0 *) - rewrite H2; now rewrite (Rtimes_0_r sor). - (* 0 < y *) - now apply (Rtimes_pos_pos sor). - (* 0 <= y *) - apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. -(* 0 <= x *) -destruct o' ; inversion H3. - (* y == 0 *) - rewrite H2; now rewrite (Rtimes_0_r sor). - (* 0 < y *) - apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ]. - (* 0 <= y *) - now apply (Rtimes_nonneg_nonneg sor). -Qed. - -Lemma OpAdd_sound : - forall (o o' oa : Op1) (e e' : R), - eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). -Proof. -unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. -(* e == 0 *) -inversion Hoa. rewrite <- H0. -destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). -(* e ~= 0 *) - destruct o'. - (* e' == 0 *) - inversion Hoa. - rewrite H2. now rewrite (Rplus_0_r sor). - (* e' ~= 0 *) - discriminate. - (* 0 < e' *) - discriminate. - (* 0 <= e' *) - discriminate. -(* 0 < e *) - destruct o'. - (* e' == 0 *) - inversion Hoa. - rewrite H2. now rewrite (Rplus_0_r sor). - (* e' ~= 0 *) - discriminate. - (* 0 < e' *) - inversion Hoa. - now apply (Rplus_pos_pos sor). - (* 0 <= e' *) - inversion Hoa. - now apply (Rplus_pos_nonneg sor). -(* 0 <= e *) - destruct o'. - (* e' == 0 *) - inversion Hoa. - now rewrite H2, (Rplus_0_r sor). - (* e' ~= 0 *) - discriminate. - (* 0 < e' *) - inversion Hoa. - now apply (Rplus_nonneg_pos sor). - (* 0 <= e' *) - inversion Hoa. - now apply (Rplus_nonneg_nonneg sor). -Qed. - -Inductive Psatz : Type := -| PsatzIn : nat -> Psatz -| PsatzSquare : PolC -> Psatz -| PsatzMulC : PolC -> Psatz -> Psatz -| PsatzMulE : Psatz -> Psatz -> Psatz -| PsatzAdd : Psatz -> Psatz -> Psatz -| PsatzC : C -> Psatz -| PsatzZ : Psatz. - -(** Given a list [l] of NFormula and an extended polynomial expression - [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a - logic consequence of the conjunction of the formulae in l. - Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) - by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) - -(* Might be defined elsewhere *) -Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B := - match o with - | None => None - | Some x => f x - end. - -Arguments map_option [A B] f o. - -Definition map_option2 (A B C : Type) (f : A -> B -> option C) - (o: option A) (o': option B) : option C := - match o , o' with - | None , _ => None - | _ , None => None - | Some x , Some x' => f x x' - end. - -Arguments map_option2 [A B C] f o o'. - -Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor). - -Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := - let (ef,o) := f in - match o with - | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal) - | _ => None - end. - -Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := - let (e1,o1) := f1 in - let (e2,o2) := f2 in - map_option (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x))) (OpMult o1 o2). - - Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := - let (e1,o1) := f1 in - let (e2,o2) := f2 in - map_option (fun x => (Some (Padd cO cplus ceqb e1 e2,x))) (OpAdd o1 o2). - - -Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := - match e with - | PsatzIn n => Some (nth n l (Pc cO, Equal)) - | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) - | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) - | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None -(* This could be 0, or <> 0 -- but these cases are useless *) - | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) - end. - - -Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), - eval_nformula env f -> pexpr_times_nformula e f = Some f' -> - eval_nformula env f'. -Proof. - unfold pexpr_times_nformula. - destruct f. - intros. destruct o ; inversion H0 ; try discriminate. - simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). - rewrite H. apply (Rtimes_0_r sor). -Qed. - -Lemma nformula_times_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_times_nformula f1 f2 = Some f -> - eval_nformula env f. -Proof. - unfold nformula_times_nformula. - destruct f1 ; destruct f2. - case_eq (OpMult o o0) ; simpl ; try discriminate. - intros. inversion H2 ; simpl. - unfold eval_pol. - destruct o1; simpl; - rewrite (Pmul_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - apply OpMult_sound with (3:= H);assumption. -Qed. - -Lemma nformula_plus_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_plus_nformula f1 f2 = Some f -> - eval_nformula env f. -Proof. - unfold nformula_plus_nformula. - destruct f1 ; destruct f2. - case_eq (OpAdd o o0) ; simpl ; try discriminate. - intros. inversion H2 ; simpl. - unfold eval_pol. - destruct o1; simpl; - rewrite (Padd_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - apply OpAdd_sound with (3:= H);assumption. -Qed. - -Lemma eval_Psatz_Sound : - forall (l : list NFormula) (env : PolEnv), - (forall (f : NFormula), In f l -> eval_nformula env f) -> - forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> - eval_nformula env f. -Proof. - induction e. - (* PsatzIn *) - simpl ; intros. - destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq]. - (* index is in bounds *) - apply H. congruence. - (* index is out-of-bounds *) - inversion H0. - rewrite Heq. simpl. - now apply (morph0 (SORrm addon)). - (* PsatzSquare *) - simpl. intros. inversion H0. - simpl. unfold eval_pol. - rewrite (Psquare_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - now apply (Rtimes_square_nonneg sor). - (* PsatzMulC *) - simpl. - intro. - case_eq (eval_Psatz l e) ; simpl ; intros. - apply IHe in H0. - apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). - discriminate. - (* PsatzMulC *) - simpl ; intro. - case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros. - apply IHe1 in H1. apply IHe2 in H0. - apply (nformula_times_nformula_correct env n0 n) ; assumption. - (* PsatzAdd *) - simpl ; intro. - case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros. - apply IHe1 in H1. apply IHe2 in H0. - apply (nformula_plus_nformula_correct env n0 n) ; assumption. - (* PsatzC *) - simpl. - intro. case_eq (cO [<] c). - intros. inversion H1. simpl. - rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. - discriminate. - (* PsatzZ *) - simpl. intros. inversion H0. - simpl. apply (morph0 (SORrm addon)). -Qed. - -Fixpoint ge_bool (n m : nat) : bool := - match n with - | O => match m with - | O => true - | S _ => false - end - | S n => match m with - | O => true - | S m => ge_bool n m - end - end. - -Lemma ge_bool_cases : forall n m, - (if ge_bool n m then n >= m else n < m)%nat. -Proof. - induction n; destruct m ; simpl; auto with arith. - specialize (IHn m). destruct (ge_bool); auto with arith. -Qed. - - -Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := - match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => acc - | PsatzMulC _ prf => xhyps_of_psatz base acc prf - | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 - | PsatzIn n => if ge_bool n base then (n::acc) else acc - end. - -Fixpoint nhyps_of_psatz (prf : Psatz) : list nat := - match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => nil - | PsatzMulC _ prf => nhyps_of_psatz prf - | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2 - | PsatzIn n => n :: nil - end. - - -Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := - match ln with - | nil => nil - | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln - end. - -Lemma extract_hyps_app : forall l ln1 ln2, - extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). -Proof. - induction ln1. - reflexivity. - simpl. - intros. - rewrite IHln1. reflexivity. -Qed. - -Ltac inv H := inversion H ; try subst ; clear H. - -Lemma nhyps_of_psatz_correct : forall (env : PolEnv) (e:Psatz) (l : list NFormula) (f: NFormula), - eval_Psatz l e = Some f -> - ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') -> eval_nformula env f). -Proof. - induction e ; intros. - (*PsatzIn*) - simpl in *. - apply H0. intuition congruence. - (* PsatzSquare *) - simpl in *. - inv H. - simpl. - unfold eval_pol. - rewrite (Psquare_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); - now apply (Rtimes_square_nonneg sor). - (* PsatzMulC *) - simpl in *. - case_eq (eval_Psatz l e). - intros. rewrite H1 in H. simpl in H. - apply pexpr_times_nformula_correct with (2:= H). - apply IHe with (1:= H1); auto. - intros. rewrite H1 in H. simpl in H ; discriminate. - (* PsatzMulE *) - simpl in *. - revert H. - case_eq (eval_Psatz l e1). - case_eq (eval_Psatz l e2) ; simpl ; intros. - apply nformula_times_nformula_correct with (3:= H2). - apply IHe1 with (1:= H1) ; auto. - intros. apply H0. rewrite extract_hyps_app. - apply in_or_app. tauto. - apply IHe2 with (1:= H) ; auto. - intros. apply H0. rewrite extract_hyps_app. - apply in_or_app. tauto. - discriminate. simpl. discriminate. - (* PsatzAdd *) - simpl in *. - revert H. - case_eq (eval_Psatz l e1). - case_eq (eval_Psatz l e2) ; simpl ; intros. - apply nformula_plus_nformula_correct with (3:= H2). - apply IHe1 with (1:= H1) ; auto. - intros. apply H0. rewrite extract_hyps_app. - apply in_or_app. tauto. - apply IHe2 with (1:= H) ; auto. - intros. apply H0. rewrite extract_hyps_app. - apply in_or_app. tauto. - discriminate. simpl. discriminate. - (* PsatzC *) - simpl in H. - case_eq (cO [<] c). - intros. rewrite H1 in H. inv H. - unfold eval_nformula. simpl. - rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. - intros. rewrite H1 in H. discriminate. - (* PsatzZ *) - simpl in *. inv H. - unfold eval_nformula. simpl. - apply (morph0 (SORrm addon)). -Qed. - - - - - - -(* roughly speaking, normalise_pexpr_correct is a proof of - forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) - -(*****) -Definition paddC := PaddC cplus. -Definition psubC := PsubC cminus. - -Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := - let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor) in - PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) - (SORrm addon). - -Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := - let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - (SORplus_wd sor) - (SORtimes_wd sor) - (SORopp_wd sor) in - PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) - (SORrm addon). - - -(* Check that a formula f is inconsistent by normalizing and comparing the -resulting constant with 0 *) - -Definition check_inconsistent (f : NFormula) : bool := -let (e, op) := f in - match e with - | Pc c => - match op with - | Equal => cneqb c cO - | NonStrict => c [<] cO - | Strict => c [<=] cO - | NonEqual => c [=] cO - end - | _ => false (* not a constant *) - end. - -Lemma check_inconsistent_sound : - forall (p : PolC) (op : Op1), - check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). -Proof. -intros p op H1 env. unfold check_inconsistent in H1. -destruct op; simpl ; -(*****) -destruct p ; simpl; try discriminate H1; -try rewrite <- (morph0 (SORrm addon)); trivial. -now apply cneqb_sound. -apply (morph_eq (SORrm addon)) in H1. congruence. -apply cleb_sound in H1. now apply -> (Rle_ngt sor). -apply cltb_sound in H1. now apply -> (Rlt_nge sor). -Qed. - - -Definition check_normalised_formulas : list NFormula -> Psatz -> bool := - fun l cm => - match eval_Psatz l cm with - | None => false - | Some f => check_inconsistent f - end. - -Lemma checker_nf_sound : - forall (l : list NFormula) (cm : Psatz), - check_normalised_formulas l cm = true -> - forall env : PolEnv, make_impl (eval_nformula env) l False. -Proof. -intros l cm H env. -unfold check_normalised_formulas in H. -revert H. -case_eq (eval_Psatz l cm) ; [|discriminate]. -intros nf. intros. -rewrite <- make_conj_impl. intro. -assert (H1' := make_conj_in _ _ H1). -assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). -destruct nf. -apply (@check_inconsistent_sound _ _ H0 env Hnf). -Qed. - -(** Normalisation of formulae **) - -Inductive Op2 : Set := (* binary relations *) -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt. - -Definition eval_op2 (o : Op2) : R -> R -> Prop := -match o with -| OpEq => req -| OpNEq => fun x y : R => x ~= y -| OpLe => rle -| OpGe => fun x y : R => y <= x -| OpLt => fun x y : R => x < y -| OpGt => fun x y : R => y < x -end. - -Definition eval_pexpr : PolEnv -> PExpr C -> R := - PEeval rplus rtimes rminus ropp phi pow_phi rpow. - -#[universes(template)] -Record Formula (T:Type) : Type := { - Flhs : PExpr T; - Fop : Op2; - Frhs : PExpr T -}. - -Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := - let (lhs, op, rhs) := f in - (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). - - -(* We normalize Formulas by moving terms to one side *) - -Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. - -Definition psub := Psub cO cplus cminus copp ceqb. - -Definition padd := Padd cO cplus ceqb. - -Definition pmul := Pmul cO cI cplus ctimes ceqb. - -Definition popp := Popp copp. - -Definition normalise (f : Formula C) : NFormula := -let (lhs, op, rhs) := f in - let lhs := norm lhs in - let rhs := norm rhs in - match op with - | OpEq => (psub lhs rhs, Equal) - | OpNEq => (psub lhs rhs, NonEqual) - | OpLe => (psub rhs lhs, NonStrict) - | OpGe => (psub lhs rhs, NonStrict) - | OpGt => (psub lhs rhs, Strict) - | OpLt => (psub rhs lhs, Strict) - end. - -Definition negate (f : Formula C) : NFormula := -let (lhs, op, rhs) := f in - let lhs := norm lhs in - let rhs := norm rhs in - match op with - | OpEq => (psub rhs lhs, NonEqual) - | OpNEq => (psub rhs lhs, Equal) - | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *) - | OpGe => (psub rhs lhs, Strict) - | OpGt => (psub rhs lhs, NonStrict) - | OpLt => (psub lhs rhs, NonStrict) - end. - -Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. -Proof. - intros. - apply (Psub_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - -Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. -Proof. - intros. - apply (Padd_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - -Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) == eval_pol env lhs * eval_pol env rhs. -Proof. - intros. - apply (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). -Qed. - -Lemma eval_pol_opp : forall env e, eval_pol env (popp e) == - eval_pol env e. -Proof. - intros. - apply (Popp_ok (SORsetoid sor) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). -Qed. - - -Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). -Proof. - intros. - apply (norm_aux_spec (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ). -Qed. - - -Theorem normalise_sound : - forall (env : PolEnv) (f : Formula C), - eval_formula env f <-> eval_nformula env (normalise f). -Proof. -intros env f; destruct f as [lhs op rhs]; simpl in *. -destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -- symmetry. - now apply (Rminus_eq_0 sor). -- rewrite (Rminus_eq_0 sor). - tauto. -- now apply (Rle_le_minus sor). -- now apply (Rle_le_minus sor). -- now apply (Rlt_lt_minus sor). -- now apply (Rlt_lt_minus sor). -Qed. - -Theorem negate_correct : - forall (env : PolEnv) (f : Formula C), - eval_formula env f <-> ~ (eval_nformula env (negate f)). -Proof. -intros env f; destruct f as [lhs op rhs]; simpl. -destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -- symmetry. rewrite (Rminus_eq_0 sor). -split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. -- rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). -- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -Qed. - -(** Another normalisation - this is used for cnf conversion **) - -Definition xnormalise (f:NFormula) : list (NFormula) := - let (e,o) := f in - match o with - | Equal => (e , Strict) :: (popp e, Strict) :: nil - | NonEqual => (e , Equal) :: nil - | Strict => (popp e, NonStrict) :: nil - | NonStrict => (popp e, Strict) :: nil - end. - -Definition xnegate (t:NFormula) : list (NFormula) := - let (e,o) := t in - match o with - | Equal => (e,Equal) :: nil - | NonEqual => (e,Strict)::(popp e,Strict)::nil - | Strict => (e,Strict) :: nil - | NonStrict => (e,NonStrict) :: nil - end. - - -Import Coq.micromega.Tauto. - -Definition cnf_of_list {T : Type} (l:list NFormula) (tg : T) : cnf NFormula T := - List.fold_right (fun x acc => - if check_inconsistent x then acc else ((x,tg)::nil)::acc) - (cnf_tt _ _) l. - -Add Ring SORRing : (SORrt sor). - -Lemma cnf_of_list_correct : - forall (T : Type) env l tg, - eval_cnf (Annot:=T) eval_nformula env (cnf_of_list l tg) <-> - make_conj (fun x : NFormula => eval_nformula env x -> False) l. -Proof. - unfold cnf_of_list. - intros T env l tg. - set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) => - if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)). - set (G := ((fun x : NFormula => eval_nformula env x -> False))). - induction l. - - compute. - tauto. - - rewrite make_conj_cons. - simpl. - unfold F at 1. - destruct (check_inconsistent a) eqn:EQ. - + rewrite IHl. - unfold G. - destruct a. - specialize (check_inconsistent_sound _ _ EQ env). - simpl. - tauto. - + - rewrite <- eval_cnf_cons_iff. - simpl. - unfold eval_tt. simpl. - rewrite IHl. - unfold G at 2. - tauto. -Qed. - -Definition cnf_normalise {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := - let f := normalise t in - if check_inconsistent f then cnf_ff _ _ - else cnf_of_list (xnormalise f) tg. - -Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := - let f := normalise t in - if check_inconsistent f then cnf_tt _ _ - else cnf_of_list (xnegate f) tg. - -Lemma eq0_cnf : forall x, - (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. -Proof. - split ; intros. - + apply (SORle_antisymm sor). - * now rewrite (Rle_ngt sor). - * rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. - + split; intro. - * rewrite (SORlt_le_neq sor) in H0. - apply (proj2 H0). - now rewrite H. - * rewrite (SORlt_le_neq sor) in H0. - apply (proj2 H0). - rewrite H. ring. -Qed. - -Lemma xnormalise_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - repeat rewrite eval_pol_opp; - generalize (eval_pol env e) as x; intro. - - apply eq0_cnf. - - unfold not. tauto. - - symmetry. rewrite (Rlt_nge sor). - rewrite (Rle_le_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. - - rewrite (Rle_ngt sor). - symmetry. - rewrite (Rlt_lt_minus sor). - setoid_replace (0 - x) with (-x) by ring. - tauto. -Qed. - - -Lemma xnegate_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. -Proof. - intros env f. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - repeat rewrite eval_pol_opp; - generalize (eval_pol env e) as x; intro. - - tauto. - - rewrite eq0_cnf. - rewrite (Req_dne sor). - tauto. - - tauto. - - tauto. -Qed. - - -Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) <-> eval_formula env t. -Proof. - intros T env t tg. - unfold cnf_normalise. - rewrite normalise_sound. - generalize (normalise t) as f;intro. - destruct (check_inconsistent f) eqn:U. - - destruct f as [e op]. - assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_ff. - tauto. - - intros. rewrite cnf_of_list_correct. - now apply xnormalise_correct. -Qed. - -Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) <-> ~ eval_formula env t. -Proof. - intros T env t tg. - rewrite normalise_sound. - unfold cnf_negate. - generalize (normalise t) as f;intro. - destruct (check_inconsistent f) eqn:U. - - - destruct f as [e o]. - assert (US := check_inconsistent_sound _ _ U env). - rewrite eval_cnf_tt. - tauto. - - rewrite cnf_of_list_correct. - apply xnegate_correct. -Qed. - -Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). -Proof. - intros. - destruct d ; simpl. - generalize (eval_pol env p); intros. - destruct o ; simpl. - apply (Req_em sor r 0). - destruct (Req_em sor r 0) ; tauto. - rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. - rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. -Qed. - -(** Reverse transformation *) - -Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := - match p with - | Pc c => PEc c - | Pinj j p => xdenorm (Pos.add j jmp ) p - | PX p j q => PEadd - (PEmul (xdenorm jmp p) (PEpow (PEX jmp) (Npos j))) - (xdenorm (Pos.succ jmp) q) - end. - -Lemma xdenorm_correct : forall p i env, - eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). -Proof. - unfold eval_pol. - induction p. - simpl. reflexivity. - (* Pinj *) - simpl. - intros. - rewrite Pos.add_succ_r. - rewrite <- IHp. - symmetry. - rewrite Pos.add_comm. - rewrite Pjump_add. reflexivity. - (* PX *) - simpl. - intros. - rewrite <- IHp1, <- IHp2. - unfold Env.tail , Env.hd. - rewrite <- Pjump_add. - rewrite Pos.add_1_r. - unfold Env.nth. - unfold jump at 2. - rewrite <- Pos.add_1_l. - rewrite (rpow_pow_N (SORpower addon)). - unfold pow_N. ring. -Qed. - -Definition denorm := xdenorm xH. - -Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). -Proof. - unfold denorm. - induction p. - reflexivity. - simpl. - rewrite Pos.add_1_r. - apply xdenorm_correct. - simpl. - intros. - rewrite IHp1. - unfold Env.tail. - rewrite xdenorm_correct. - change (Pos.succ xH) with 2%positive. - rewrite (rpow_pow_N (SORpower addon)). - simpl. reflexivity. -Qed. - - -(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real" -coefficients that are used to actually compute *) - - - -Variable S : Type. - -Variable C_of_S : S -> C. - -Variable phiS : S -> R. - -Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). - -Fixpoint map_PExpr (e : PExpr S) : PExpr C := - match e with - | PEc c => PEc (C_of_S c) - | PEX p => PEX p - | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) - | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) - | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) - | PEopp e => PEopp (map_PExpr e) - | PEpow e n => PEpow (map_PExpr e) n - end. - -Definition map_Formula (f : Formula S) : Formula C := - let (l,o,r) := f in - Build_Formula (map_PExpr l) o (map_PExpr r). - - -Definition eval_sexpr : PolEnv -> PExpr S -> R := - PEeval rplus rtimes rminus ropp phiS pow_phi rpow. - -Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := - let (lhs, op, rhs) := f in - (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs). - -Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). -Proof. - unfold eval_pexpr, eval_sexpr. - induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. - apply phi_C_of_S. - rewrite IHs. reflexivity. - rewrite IHs. reflexivity. -Qed. - -(** equality might be (too) strong *) -Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). -Proof. - destruct f. - simpl. - repeat rewrite eval_pexprSC. - reflexivity. -Qed. - - - - -(** Some syntactic simplifications of expressions *) - - -Definition simpl_cone (e:Psatz) : Psatz := - match e with - | PsatzSquare t => - match t with - | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ => PsatzSquare t - end - | PsatzMulE t1 t2 => - match t1 , t2 with - | PsatzZ , x => PsatzZ - | x , PsatzZ => PsatzZ - | PsatzC c , PsatzC c' => PsatzC (ctimes c c') - | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x - | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z) - | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2 - | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 - | _ , _ => e - end - | PsatzAdd t1 t2 => - match t1 , t2 with - | PsatzZ , x => x - | x , PsatzZ => x - | x , y => PsatzAdd x y - end - | _ => e - end. - - - - -End Micromega. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v deleted file mode 100644 index a155207e2e..0000000000 --- a/plugins/micromega/Tauto.v +++ /dev/null @@ -1,1390 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-20019 *) -(* *) -(************************************************************************) - -Require Import List. -Require Import Refl. -Require Import Bool. - -Set Implicit Arguments. - - -Section S. - Context {TA : Type}. (* type of interpreted atoms *) - Context {TX : Type}. (* type of uninterpreted terms (Prop) *) - Context {AA : Type}. (* type of annotations for atoms *) - Context {AF : Type}. (* type of formulae identifiers *) - - Inductive GFormula : Type := - | TT : GFormula - | FF : GFormula - | X : TX -> GFormula - | A : TA -> AA -> GFormula - | Cj : GFormula -> GFormula -> GFormula - | D : GFormula -> GFormula -> GFormula - | N : GFormula -> GFormula - | I : GFormula -> option AF -> GFormula -> GFormula. - - Section MAPX. - Variable F : TX -> TX. - - Fixpoint mapX (f : GFormula) : GFormula := - match f with - | TT => TT - | FF => FF - | X x => X (F x) - | A a an => A a an - | Cj f1 f2 => Cj (mapX f1) (mapX f2) - | D f1 f2 => D (mapX f1) (mapX f2) - | N f => N (mapX f) - | I f1 o f2 => I (mapX f1) o (mapX f2) - end. - - End MAPX. - - Section FOLDANNOT. - Variable ACC : Type. - Variable F : ACC -> AA -> ACC. - - Fixpoint foldA (f : GFormula) (acc : ACC) : ACC := - match f with - | TT => acc - | FF => acc - | X x => acc - | A a an => F acc an - | Cj f1 f2 - | D f1 f2 - | I f1 _ f2 => foldA f1 (foldA f2 acc) - | N f => foldA f acc - end. - - End FOLDANNOT. - - - Definition cons_id (id : option AF) (l : list AF) := - match id with - | None => l - | Some id => id :: l - end. - - Fixpoint ids_of_formula f := - match f with - | I f id f' => cons_id id (ids_of_formula f') - | _ => nil - end. - - Fixpoint collect_annot (f : GFormula) : list AA := - match f with - | TT | FF | X _ => nil - | A _ a => a ::nil - | Cj f1 f2 - | D f1 f2 - | I f1 _ f2 => collect_annot f1 ++ collect_annot f2 - | N f => collect_annot f - end. - - Variable ex : TX -> Prop. (* [ex] will be the identity *) - - Section EVAL. - - Variable ea : TA -> Prop. - - Fixpoint eval_f (f:GFormula) {struct f}: Prop := - match f with - | TT => True - | FF => False - | A a _ => ea a - | X p => ex p - | Cj e1 e2 => (eval_f e1) /\ (eval_f e2) - | D e1 e2 => (eval_f e1) \/ (eval_f e2) - | N e => ~ (eval_f e) - | I f1 _ f2 => (eval_f f1) -> (eval_f f2) - end. - - - End EVAL. - - - - - - Lemma eval_f_morph : - forall (ev ev' : TA -> Prop) (f : GFormula), - (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). - Proof. - induction f ; simpl ; try tauto. - intros. - apply H. - Qed. - - -End S. - - - -(** Typical boolean formulae *) -Definition BFormula (A : Type) := @GFormula A Prop unit unit. - -Section MAPATOMS. - Context {TA TA':Type}. - Context {TX : Type}. - Context {AA : Type}. - Context {AF : Type}. - - -Fixpoint map_bformula (fct : TA -> TA') (f : @GFormula TA TX AA AF ) : @GFormula TA' TX AA AF := - match f with - | TT => TT - | FF => FF - | X p => X p - | A a t => A (fct a) t - | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) - | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) - | N f => N (map_bformula fct f) - | I f1 a f2 => I (map_bformula fct f1) a (map_bformula fct f2) - end. - -End MAPATOMS. - -Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. -Proof. - destruct l ; reflexivity. -Qed. - - -Section S. - (** A cnf tracking annotations of atoms. *) - - (** Type parameters *) - Variable Env : Type. - Variable Term : Type. - Variable Term' : Type. - Variable Annot : Type. - - Variable unsat : Term' -> bool. (* see [unsat_prop] *) - Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *) - - Definition clause := list (Term' * Annot). - Definition cnf := list clause. - - Variable normalise : Term -> Annot -> cnf. - Variable negate : Term -> Annot -> cnf. - - - Definition cnf_tt : cnf := @nil clause. - Definition cnf_ff : cnf := cons (@nil (Term' * Annot)) nil. - - (** Our cnf is optimised and detects contradictions on the fly. *) - - Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause := - match cl with - | nil => - match deduce (fst t) (fst t) with - | None => Some (t ::nil) - | Some u => if unsat u then None else Some (t::nil) - end - | t'::cl => - match deduce (fst t) (fst t') with - | None => - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - | Some u => - if unsat u then None else - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - end - end. - - Fixpoint or_clause (cl1 cl2 : clause) : option clause := - match cl1 with - | nil => Some cl2 - | t::cl => match add_term t cl2 with - | None => None - | Some cl' => or_clause cl cl' - end - end. - - Definition xor_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_left (fun acc e => - match or_clause t e with - | None => acc - | Some cl => cl :: acc - end) f nil . - - Definition or_clause_cnf (t: clause) (f:cnf) : cnf := - match t with - | nil => f - | _ => xor_clause_cnf t f - end. - - - Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := - match f with - | nil => cnf_tt - | e :: rst => (or_cnf rst f') +++ (or_clause_cnf e f') - end. - - - Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := - f1 +++ f2. - - (** TX is Prop in Coq and EConstr.constr in Ocaml. - AF i s unit in Coq and Names.Id.t in Ocaml - *) - Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. - - - Definition is_cnf_tt (c : cnf) : bool := - match c with - | nil => true - | _ => false - end. - - Definition is_cnf_ff (c : cnf) : bool := - match c with - | nil::nil => true - | _ => false - end. - - Definition and_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := - if is_cnf_ff f1 || is_cnf_ff f2 - then cnf_ff - else and_cnf f1 f2. - - Definition or_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := - if is_cnf_tt f1 || is_cnf_tt f2 - then cnf_tt - else if is_cnf_ff f2 - then f1 else or_cnf f1 f2. - - Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := - match f with - | TT => if pol then cnf_tt else cnf_ff - | FF => if pol then cnf_ff else cnf_tt - | X p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *) - | A x t => if pol then normalise x t else negate x t - | N e => xcnf (negb pol) e - | Cj e1 e2 => - (if pol then and_cnf_opt else or_cnf_opt) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf_opt else and_cnf_opt) (xcnf pol e1) (xcnf pol e2) - | I e1 _ e2 - => (if pol then or_cnf_opt else and_cnf_opt) (xcnf (negb pol) e1) (xcnf pol e2) - end. - - Section CNFAnnot. - - (** Records annotations used to optimise the cnf. - Those need to be kept when pruning the formula. - For efficiency, this is a separate function. - *) - - Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := - match cl with - | nil => (* if t is unsat, the clause is empty BUT t is needed. *) - match deduce (fst t) (fst t) with - | Some u => if unsat u then inr ((snd t)::nil) else inl (t::nil) - | None => inl (t::nil) - end - | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *) - match deduce (fst t) (fst t') with - | Some u => if unsat u then inr ((snd t)::(snd t')::nil) - else match radd_term t cl with - | inl cl' => inl (t'::cl') - | inr l => inr l - end - | None => match radd_term t cl with - | inl cl' => inl (t'::cl') - | inr l => inr l - end - end - end. - - Fixpoint ror_clause cl1 cl2 := - match cl1 with - | nil => inl cl2 - | t::cl => match radd_term t cl2 with - | inl cl' => ror_clause cl cl' - | inr l => inr l - end - end. - - Definition xror_clause_cnf t f := - List.fold_left (fun '(acc,tg) e => - match ror_clause t e with - | inl cl => (cl :: acc,tg) - | inr l => (acc,tg+++l) - end) f (nil,nil). - - Definition ror_clause_cnf t f := - match t with - | nil => (f,nil) - | _ => xror_clause_cnf t f - end. - - - Fixpoint ror_cnf (f f':list clause) := - match f with - | nil => (cnf_tt,nil) - | e :: rst => - let (rst_f',t) := ror_cnf rst f' in - let (e_f', t') := ror_clause_cnf e f' in - (rst_f' +++ e_f', t +++ t') - end. - - Definition annot_of_clause (l : clause) : list Annot := - List.map snd l. - - Definition annot_of_cnf (f : cnf) : list Annot := - List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil. - - - Definition ror_cnf_opt f1 f2 := - if is_cnf_tt f1 - then (cnf_tt , nil) - else if is_cnf_tt f2 - then (cnf_tt, nil) - else if is_cnf_ff f2 - then (f1,nil) - else ror_cnf f1 f2. - - - Definition ocons {A : Type} (o : option A) (l : list A) : list A := - match o with - | None => l - | Some e => e ::l - end. - - Definition ratom (c : cnf) (a : Annot) : cnf * list Annot := - if is_cnf_ff c || is_cnf_tt c - then (c,a::nil) - else (c,nil). (* t is embedded in c *) - - Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) : cnf * list Annot := - match f with - | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) - | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) - | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) - | A x t => ratom (if polarity then normalise x t else negate x t) t - | N e => rxcnf (negb polarity) e - | Cj e1 e2 => - let '(e1,t1) := rxcnf polarity e1 in - let '(e2,t2) := rxcnf polarity e2 in - if polarity - then (and_cnf_opt e1 e2, t1 +++ t2) - else let (f',t') := ror_cnf_opt e1 e2 in - (f', t1 +++ t2 +++ t') - | D e1 e2 => - let '(e1,t1) := rxcnf polarity e1 in - let '(e2,t2) := rxcnf polarity e2 in - if polarity - then let (f',t') := ror_cnf_opt e1 e2 in - (f', t1 +++ t2 +++ t') - else (and_cnf_opt e1 e2, t1 +++ t2) - | I e1 a e2 => - let '(e1 , t1) := (rxcnf (negb polarity) e1) in - if polarity - then - if is_cnf_ff e1 - then - rxcnf polarity e2 - else (* compute disjunction *) - let '(e2 , t2) := (rxcnf polarity e2) in - let (f',t') := ror_cnf_opt e1 e2 in - (f', t1 +++ t2 +++ t') (* record the hypothesis *) - else - let '(e2 , t2) := (rxcnf polarity e2) in - (and_cnf_opt e1 e2, t1 +++ t2) - end. - - - Section Abstraction. - Variable TX : Type. - Variable AF : Type. - - Class to_constrT : Type := - { - mkTT : TX; - mkFF : TX; - mkA : Term -> Annot -> TX; - mkCj : TX -> TX -> TX; - mkD : TX -> TX -> TX; - mkI : TX -> TX -> TX; - mkN : TX -> TX - }. - - Context {to_constr : to_constrT}. - - Fixpoint aformula (f : TFormula TX AF) : TX := - match f with - | TT => mkTT - | FF => mkFF - | X p => p - | A x t => mkA x t - | Cj f1 f2 => mkCj (aformula f1) (aformula f2) - | D f1 f2 => mkD (aformula f1) (aformula f2) - | I f1 o f2 => mkI (aformula f1) (aformula f2) - | N f => mkN (aformula f) - end. - - - Definition is_X (f : TFormula TX AF) : option TX := - match f with - | X p => Some p - | _ => None - end. - - Definition is_X_inv : forall f x, - is_X f = Some x -> f = X x. - Proof. - destruct f ; simpl ; congruence. - Qed. - - - Variable needA : Annot -> bool. - - Definition abs_and (f1 f2 : TFormula TX AF) - (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := - match is_X f1 , is_X f2 with - | Some _ , _ | _ , Some _ => X (aformula (c f1 f2)) - | _ , _ => c f1 f2 - end. - - Definition abs_or (f1 f2 : TFormula TX AF) - (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := - match is_X f1 , is_X f2 with - | Some _ , Some _ => X (aformula (c f1 f2)) - | _ , _ => c f1 f2 - end. - - Definition mk_arrow (o : option AF) (f1 f2: TFormula TX AF) := - match o with - | None => I f1 None f2 - | Some _ => if is_X f1 then f2 else I f1 o f2 - end. - - - Fixpoint abst_form (pol : bool) (f : TFormula TX AF) := - match f with - | TT => if pol then TT else X mkTT - | FF => if pol then X mkFF else FF - | X p => X p - | A x t => if needA t then A x t else X (mkA x t) - | Cj f1 f2 => - let f1 := abst_form pol f1 in - let f2 := abst_form pol f2 in - if pol then abs_and f1 f2 Cj - else abs_or f1 f2 Cj - | D f1 f2 => - let f1 := abst_form pol f1 in - let f2 := abst_form pol f2 in - if pol then abs_or f1 f2 D - else abs_and f1 f2 D - | I f1 o f2 => - let f1 := abst_form (negb pol) f1 in - let f2 := abst_form pol f2 in - if pol - then abs_or f1 f2 (mk_arrow o) - else abs_and f1 f2 (mk_arrow o) - | N f => let f := abst_form (negb pol) f in - match is_X f with - | Some a => X (mkN a) - | _ => N f - end - end. - - - - - Lemma if_same : forall {A: Type} (b:bool) (t:A), - (if b then t else t) = t. - Proof. - destruct b ; reflexivity. - Qed. - - Lemma is_cnf_tt_cnf_ff : - is_cnf_tt cnf_ff = false. - Proof. - reflexivity. - Qed. - - Lemma is_cnf_ff_cnf_ff : - is_cnf_ff cnf_ff = true. - Proof. - reflexivity. - Qed. - - - Lemma is_cnf_tt_inv : forall f1, - is_cnf_tt f1 = true -> f1 = cnf_tt. - Proof. - unfold cnf_tt. - destruct f1 ; simpl ; try congruence. - Qed. - - Lemma is_cnf_ff_inv : forall f1, - is_cnf_ff f1 = true -> f1 = cnf_ff. - Proof. - unfold cnf_ff. - destruct f1 ; simpl ; try congruence. - destruct c ; simpl ; try congruence. - destruct f1 ; try congruence. - reflexivity. - Qed. - - - Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f. - Proof. - intros. - destruct (is_cnf_tt f) eqn:EQ. - apply is_cnf_tt_inv in EQ;auto. - reflexivity. - Qed. - - Lemma or_cnf_opt_cnf_ff : forall f, - or_cnf_opt cnf_ff f = f. - Proof. - intros. - unfold or_cnf_opt. - rewrite is_cnf_tt_cnf_ff. - simpl. - destruct (is_cnf_tt f) eqn:EQ. - apply is_cnf_tt_inv in EQ. - congruence. - destruct (is_cnf_ff f) eqn:EQ1. - apply is_cnf_ff_inv in EQ1. - congruence. - reflexivity. - Qed. - - Lemma abs_and_pol : forall f1 f2 pol, - and_cnf_opt (xcnf pol f1) (xcnf pol f2) = - xcnf pol (abs_and f1 f2 (if pol then Cj else D)). - Proof. - unfold abs_and; intros. - destruct (is_X f1) eqn:EQ1. - apply is_X_inv in EQ1. - subst. - simpl. - rewrite if_same. reflexivity. - destruct (is_X f2) eqn:EQ2. - apply is_X_inv in EQ2. - subst. - simpl. - rewrite if_same. - unfold and_cnf_opt. - rewrite orb_comm. reflexivity. - destruct pol ; simpl; auto. - Qed. - - Lemma abs_or_pol : forall f1 f2 pol, - or_cnf_opt (xcnf pol f1) (xcnf pol f2) = - xcnf pol (abs_or f1 f2 (if pol then D else Cj)). - Proof. - unfold abs_or; intros. - destruct (is_X f1) eqn:EQ1. - apply is_X_inv in EQ1. - subst. - destruct (is_X f2) eqn:EQ2. - apply is_X_inv in EQ2. - subst. - simpl. - rewrite if_same. - reflexivity. - simpl. - rewrite if_same. - destruct pol ; simpl; auto. - destruct pol ; simpl ; auto. - Qed. - - Variable needA_all : forall a, needA a = true. - - Lemma xcnf_true_mk_arrow_l : forall o t f, - xcnf true (mk_arrow o (X t) f) = xcnf true f. - Proof. - destruct o ; simpl; auto. - intros. rewrite or_cnf_opt_cnf_ff. reflexivity. - Qed. - - Lemma or_cnf_opt_cnf_ff_r : forall f, - or_cnf_opt f cnf_ff = f. - Proof. - unfold or_cnf_opt. - intros. - rewrite is_cnf_tt_cnf_ff. - rewrite orb_comm. - simpl. - apply if_cnf_tt. - Qed. - - Lemma xcnf_true_mk_arrow_r : forall o t f, - xcnf true (mk_arrow o f (X t)) = xcnf false f. - Proof. - destruct o ; simpl; auto. - - intros. - destruct (is_X f) eqn:EQ. - apply is_X_inv in EQ. subst. reflexivity. - simpl. - apply or_cnf_opt_cnf_ff_r. - - intros. - apply or_cnf_opt_cnf_ff_r. - Qed. - - - - Lemma abst_form_correct : forall f pol, - xcnf pol f = xcnf pol (abst_form pol f). - Proof. - induction f;intros. - - simpl. destruct pol ; reflexivity. - - simpl. destruct pol ; reflexivity. - - simpl. reflexivity. - - simpl. rewrite needA_all. - reflexivity. - - simpl. - specialize (IHf1 pol). - specialize (IHf2 pol). - rewrite IHf1. - rewrite IHf2. - destruct pol. - + - apply abs_and_pol; auto. - + - apply abs_or_pol; auto. - - simpl. - specialize (IHf1 pol). - specialize (IHf2 pol). - rewrite IHf1. - rewrite IHf2. - destruct pol. - + - apply abs_or_pol; auto. - + - apply abs_and_pol; auto. - - simpl. - specialize (IHf (negb pol)). - destruct (is_X (abst_form (negb pol) f)) eqn:EQ1. - + apply is_X_inv in EQ1. - rewrite EQ1 in *. - simpl in *. - destruct pol ; auto. - + simpl. congruence. - - simpl. - specialize (IHf1 (negb pol)). - specialize (IHf2 pol). - destruct pol. - + - simpl in *. - unfold abs_or. - destruct (is_X (abst_form false f1)) eqn:EQ1; - destruct (is_X (abst_form true f2)) eqn:EQ2 ; simpl. - * apply is_X_inv in EQ1. - apply is_X_inv in EQ2. - rewrite EQ1 in *. - rewrite EQ2 in *. - rewrite IHf1. rewrite IHf2. - simpl. reflexivity. - * apply is_X_inv in EQ1. - rewrite EQ1 in *. - rewrite IHf1. - simpl. - rewrite xcnf_true_mk_arrow_l. - rewrite or_cnf_opt_cnf_ff. - congruence. - * apply is_X_inv in EQ2. - rewrite EQ2 in *. - rewrite IHf2. - simpl. - rewrite xcnf_true_mk_arrow_r. - rewrite or_cnf_opt_cnf_ff_r. - congruence. - * destruct o ; simpl ; try congruence. - rewrite EQ1. - simpl. congruence. - + simpl in *. - unfold abs_and. - destruct (is_X (abst_form true f1)) eqn:EQ1; - destruct (is_X (abst_form false f2)) eqn:EQ2 ; simpl. - * apply is_X_inv in EQ1. - apply is_X_inv in EQ2. - rewrite EQ1 in *. - rewrite EQ2 in *. - rewrite IHf1. rewrite IHf2. - simpl. reflexivity. - * apply is_X_inv in EQ1. - rewrite EQ1 in *. - rewrite IHf1. - simpl. reflexivity. - * apply is_X_inv in EQ2. - rewrite EQ2 in *. - rewrite IHf2. - simpl. unfold and_cnf_opt. - rewrite orb_comm. reflexivity. - * destruct o; simpl. - rewrite EQ1. simpl. - congruence. - congruence. - Qed. - - End Abstraction. - - - End CNFAnnot. - - - Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl. - Proof. - induction a' ; simpl. - - intros. - destruct (deduce (fst a) (fst a)). - destruct (unsat t). congruence. - inversion H. reflexivity. - inversion H ;reflexivity. - - intros. - destruct (deduce (fst a0) (fst a)). - destruct (unsat t). congruence. - destruct (radd_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - destruct (radd_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - Qed. - - Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl. - Proof. - induction a' ; simpl. - - intros. - destruct (deduce (fst a) (fst a)). - destruct (unsat t). congruence. - inversion H. reflexivity. - inversion H ;reflexivity. - - intros. - destruct (deduce (fst a0) (fst a)). - destruct (unsat t). congruence. - destruct (add_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - destruct (add_term a0 a') eqn:RADD; try congruence. - inversion H. subst. - apply IHa' in RADD. - rewrite RADD. - reflexivity. - Qed. - - Lemma xror_clause_clause : forall a f, - fst (xror_clause_cnf a f) = xor_clause_cnf a f. - Proof. - unfold xror_clause_cnf. - unfold xor_clause_cnf. - assert (ACC: fst (@nil clause,@nil Annot) = nil). - reflexivity. - intros. - set (F1:= (fun '(acc, tg) (e : clause) => - match ror_clause a e with - | inl cl => (cl :: acc, tg) - | inr l => (acc, tg +++ l) - end)). - set (F2:= (fun (acc : list clause) (e : clause) => - match or_clause a e with - | Some cl => cl :: acc - | None => acc - end)). - revert ACC. - generalize (@nil clause,@nil Annot). - generalize (@nil clause). - induction f ; simpl ; auto. - intros. - apply IHf. - unfold F1 , F2. - destruct p ; simpl in * ; subst. - clear. - revert a0. - induction a; simpl; auto. - intros. - destruct (radd_term a a1) eqn:RADD. - apply radd_term_term in RADD. - rewrite RADD. - auto. - destruct (add_term a a1) eqn:RADD'. - apply radd_term_term' in RADD'. - congruence. - reflexivity. - Qed. - - Lemma ror_clause_clause : forall a f, - fst (ror_clause_cnf a f) = or_clause_cnf a f. - Proof. - unfold ror_clause_cnf,or_clause_cnf. - destruct a ; auto. - apply xror_clause_clause. - Qed. - - Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2. - Proof. - induction f1 ; simpl ; auto. - intros. - specialize (IHf1 f2). - destruct(ror_cnf f1 f2). - rewrite <- ror_clause_clause. - destruct(ror_clause_cnf a f2). - simpl. - rewrite <- IHf1. - reflexivity. - Qed. - - Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2. - Proof. - unfold ror_cnf_opt, or_cnf_opt. - intros. - destruct (is_cnf_tt f1). - - simpl ; auto. - - simpl. destruct (is_cnf_tt f2) ; simpl ; auto. - destruct (is_cnf_ff f2) eqn:EQ. - reflexivity. - apply ror_cnf_cnf. - Qed. - - Lemma ratom_cnf : forall f a, - fst (ratom f a) = f. - Proof. - unfold ratom. - intros. - destruct (is_cnf_ff f || is_cnf_tt f); auto. - Qed. - - - - Lemma rxcnf_xcnf : forall {TX AF:Type} (f:TFormula TX AF) b, - fst (rxcnf b f) = xcnf b f. - Proof. - induction f ; simpl ; auto. - - destruct b; simpl ; auto. - - destruct b; simpl ; auto. - - destruct b ; simpl ; auto. - - intros. rewrite ratom_cnf. reflexivity. - - intros. - specialize (IHf1 b). - specialize (IHf2 b). - destruct (rxcnf b f1). - destruct (rxcnf b f2). - simpl in *. - subst. destruct b ; auto. - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf false f1) (xcnf false f2)). - reflexivity. - - intros. - specialize (IHf1 b). - specialize (IHf2 b). - rewrite <- IHf1. - rewrite <- IHf2. - destruct (rxcnf b f1). - destruct (rxcnf b f2). - simpl in *. - subst. destruct b ; auto. - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf true f1) (xcnf true f2)). - reflexivity. - - intros. - specialize (IHf1 (negb b)). - specialize (IHf2 b). - rewrite <- IHf1. - rewrite <- IHf2. - destruct (rxcnf (negb b) f1). - destruct (rxcnf b f2). - simpl in *. - subst. - destruct b;auto. - generalize (is_cnf_ff_inv (xcnf (negb true) f1)). - destruct (is_cnf_ff (xcnf (negb true) f1)). - + intros. - rewrite H by auto. - unfold or_cnf_opt. - simpl. - destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto. - apply is_cnf_tt_inv in EQ; auto. - destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. - apply is_cnf_ff_inv in EQ1. congruence. - reflexivity. - + - rewrite <- ror_opt_cnf_cnf. - destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). - intros. - reflexivity. - Qed. - - - Variable eval' : Env -> Term' -> Prop. - - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). - - - Variable unsat_prop : forall t, unsat t = true -> - forall env, eval' env t -> False. - - - - Variable deduce_prop : forall t t' u, - deduce t t' = Some u -> forall env, - eval' env t -> eval' env t' -> eval' env u. - - - - Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt). - - - Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval_tt env) cl. - - Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - - - Lemma eval_cnf_app : forall env x y, eval_cnf env (x+++y) <-> eval_cnf env x /\ eval_cnf env y. - Proof. - unfold eval_cnf. - intros. - rewrite make_conj_rapp. - rewrite make_conj_app ; auto. - tauto. - Qed. - - - Lemma eval_cnf_ff : forall env, eval_cnf env cnf_ff <-> False. - Proof. - unfold cnf_ff, eval_cnf,eval_clause. - simpl. tauto. - Qed. - - Lemma eval_cnf_tt : forall env, eval_cnf env cnf_tt <-> True. - Proof. - unfold cnf_tt, eval_cnf,eval_clause. - simpl. tauto. - Qed. - - - Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y). - Proof. - unfold and_cnf_opt. - intros. - destruct (is_cnf_ff x) eqn:F1. - { apply is_cnf_ff_inv in F1. - simpl. subst. - unfold and_cnf. - rewrite eval_cnf_app. - rewrite eval_cnf_ff. - tauto. - } - simpl. - destruct (is_cnf_ff y) eqn:F2. - { apply is_cnf_ff_inv in F2. - simpl. subst. - unfold and_cnf. - rewrite eval_cnf_app. - rewrite eval_cnf_ff. - tauto. - } - tauto. - Qed. - - - - Definition eval_opt_clause (env : Env) (cl: option clause) := - match cl with - | None => True - | Some cl => eval_clause env cl - end. - - - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl). - Proof. - induction cl. - - (* BC *) - simpl. - case_eq (deduce (fst t) (fst t)) ; try tauto. - intros. - generalize (@deduce_prop _ _ _ H env). - case_eq (unsat t0) ; try tauto. - { intros. - generalize (@unsat_prop _ H0 env). - unfold eval_clause. - rewrite make_conj_cons. - simpl; intros. - tauto. - } - - (* IC *) - simpl. - case_eq (deduce (fst t) (fst a)); - intros. - generalize (@deduce_prop _ _ _ H env). - case_eq (unsat t0); intros. - { - generalize (@unsat_prop _ H0 env). - simpl. - unfold eval_clause. - repeat rewrite make_conj_cons. - tauto. - } - destruct (add_term t cl) ; simpl in * ; try tauto. - { - intros. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - } - { - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - } - destruct (add_term t cl) ; simpl in *; - unfold eval_clause in * ; - repeat rewrite make_conj_cons in *; tauto. - Qed. - - - Lemma no_middle_eval_tt : forall env a, - eval_tt env a \/ ~ eval_tt env a. - Proof. - unfold eval_tt. - auto. - Qed. - - Hint Resolve no_middle_eval_tt : tauto. - - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. - Proof. - induction cl. - - simpl. unfold eval_clause at 2. simpl. tauto. - - intros *. - simpl. - assert (HH := add_term_correct env a cl'). - assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval'). - destruct (add_term a cl'); simpl in *. - + - rewrite IHcl. - unfold eval_clause in *. - rewrite !make_conj_cons in *. - tauto. - + unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - Qed. - - - Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) <-> (eval_clause env t) \/ (eval_cnf env f). - Proof. - unfold eval_cnf. - unfold or_clause_cnf. - intros until t. - set (F := (fun (acc : list clause) (e : clause) => - match or_clause t e with - | Some cl => cl :: acc - | None => acc - end)). - intro f. - assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil). - { - generalize (@nil clause) as acc. - induction f. - - simpl. - intros ; tauto. - - intros. - simpl fold_left. - rewrite IHf. - rewrite make_conj_cons. - unfold F in *; clear F. - generalize (or_clause_correct t a env). - destruct (or_clause t a). - + - rewrite make_conj_cons. - simpl. tauto. - + simpl. tauto. - } - destruct t ; auto. - - unfold eval_clause ; simpl. tauto. - - unfold xor_clause_cnf. - unfold F in H. - rewrite H. - unfold make_conj at 2. tauto. - Qed. - - - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a /\ eval_cnf env f) <-> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - unfold eval_clause at 2. - tauto. - Qed. - - Lemma eval_cnf_cons_iff : forall env a f, ((~ make_conj (eval_tt env) a) /\ eval_cnf env f) <-> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - unfold eval_clause. - tauto. - Qed. - - - Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env f) \/ (eval_cnf env f'). - Proof. - induction f. - unfold eval_cnf. - simpl. - tauto. - (**) - intros. - simpl. - rewrite eval_cnf_app. - rewrite <- eval_cnf_cons_iff. - rewrite IHf. - rewrite or_clause_cnf_correct. - unfold eval_clause. - tauto. - Qed. - - Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f'). - Proof. - unfold or_cnf_opt. - intros. - destruct (is_cnf_tt f) eqn:TF. - { simpl. - apply is_cnf_tt_inv in TF. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_tt. - tauto. - } - destruct (is_cnf_tt f') eqn:TF'. - { simpl. - apply is_cnf_tt_inv in TF'. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_tt. - tauto. - } - { simpl. - destruct (is_cnf_ff f') eqn:EQ. - apply is_cnf_ff_inv in EQ. - subst. - rewrite or_cnf_correct. - rewrite eval_cnf_ff. - tauto. - tauto. - } - Qed. - - - Variable eval : Env -> Term -> Prop. - - Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. - - Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. - - Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). - Proof. - induction f. - - (* TT *) - unfold eval_cnf. - simpl. - destruct pol ; simpl ; auto. - - (* FF *) - unfold eval_cnf. - destruct pol; simpl ; auto. - unfold eval_clause ; simpl. - tauto. - - (* P *) - simpl. - destruct pol ; intros ;simpl. - unfold eval_cnf in H. - (* Here I have to drop the proposition *) - simpl in H. - unfold eval_clause in H ; simpl in H. - tauto. - (* Here, I could store P in the clause *) - unfold eval_cnf in H;simpl in H. - unfold eval_clause in H ; simpl in H. - tauto. - - (* A *) - simpl. - destruct pol ; simpl. - intros. - eapply normalise_correct ; eauto. - (* A 2 *) - intros. - eapply negate_correct ; eauto. - - (* Cj *) - destruct pol ; simpl. - + (* pol = true *) - intros. - rewrite eval_cnf_and_opt in H. - unfold and_cnf in H. - rewrite eval_cnf_app in H. - destruct H. - split. - apply (IHf1 _ _ H). - apply (IHf2 _ _ H0). - + (* pol = false *) - intros. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - generalize (IHf1 false env H). - simpl. - tauto. - generalize (IHf2 false env H). - simpl. - tauto. - - (* D *) - simpl. - destruct pol. - + (* pol = true *) - intros. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - generalize (IHf1 _ env H). - simpl. - tauto. - generalize (IHf2 _ env H). - simpl. - tauto. - + (* pol = true *) - intros. - rewrite eval_cnf_and_opt in H. - unfold and_cnf. - rewrite eval_cnf_app in H. - destruct H as [H0 H1]. - simpl. - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. - - (**) - simpl. - destruct pol ; simpl. - intros. - apply (IHf false) ; auto. - intros. - generalize (IHf _ _ H). - tauto. - - (* I *) - simpl; intros. - destruct pol. - + simpl. - intro. - rewrite or_cnf_opt_correct in H. - rewrite or_cnf_correct in H. - destruct H as [H | H]. - generalize (IHf1 _ _ H). - simpl in *. - tauto. - generalize (IHf2 _ _ H). - auto. - + (* pol = false *) - rewrite eval_cnf_and_opt in H. - unfold and_cnf in H. - simpl in H. - rewrite eval_cnf_app in H. - destruct H as [H0 H1]. - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. - Qed. - - - Variable Witness : Type. - Variable checker : list (Term'*Annot) -> Witness -> bool. - - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval_tt env) t False. - - Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := - match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. - - Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. - Proof. - unfold eval_cnf. - induction t. - (* bc *) - simpl. - auto. - (* ic *) - simpl. - destruct w. - intros ; discriminate. - case_eq (checker a w) ; intros ; try discriminate. - generalize (@checker_sound _ _ H env). - generalize (IHt _ H0 env) ; intros. - destruct t. - red ; intro. - rewrite <- make_conj_impl in H2. - tauto. - rewrite <- make_conj_impl in H2. - tauto. - Qed. - - - Definition tauto_checker (f:@GFormula Term Prop Annot unit) (w:list Witness) : bool := - cnf_checker (xcnf true f) w. - - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (fun x => x) (eval env) t. - Proof. - unfold tauto_checker. - intros. - change (eval_f (fun x => x) (eval env) t) with (eval_f (fun x => x) (eval env) (if true then t else TT)). - apply (xcnf_correct t true). - eapply cnf_checker_sound ; eauto. - Qed. - - Definition eval_bf {A : Type} (ea : A -> Prop) (f: BFormula A) := eval_f (fun x => x) ea f. - - - Lemma eval_bf_map : forall T U (fct: T-> U) env f , - eval_bf env (map_bformula fct f) = eval_bf (fun x => env (fct x)) f. -Proof. - induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. - rewrite <- IHf. auto. -Qed. - - -End S. - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v deleted file mode 100644 index 6db62e8401..0000000000 --- a/plugins/micromega/VarMap.v +++ /dev/null @@ -1,79 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import ZArith_base. -Require Import Coq.Arith.Max. -Require Import List. -Set Implicit Arguments. - -(* - * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v) - * --- it is harmless and spares a lot of Empty. - * It also means smaller proof-terms. - * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up. - *) - -Inductive t {A} : Type := -| Empty : t -| Elt : A -> t -| Branch : t -> A -> t -> t . -Arguments t : clear implicits. - -Section MakeVarMap. - - Variable A : Type. - Variable default : A. - - Notation t := (t A). - - Fixpoint find (vm : t) (p:positive) {struct vm} : A := - match vm with - | Empty => default - | Elt i => i - | Branch l e r => match p with - | xH => e - | xO p => find l p - | xI p => find r p - end - end. - - Fixpoint singleton (x:positive) (v : A) : t := - match x with - | xH => Elt v - | xO p => Branch (singleton p v) default Empty - | xI p => Branch Empty default (singleton p v) - end. - - Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := - match m with - | Empty => singleton x v - | Elt vl => - match x with - | xH => Elt v - | xO p => Branch (singleton p v) vl Empty - | xI p => Branch Empty vl (singleton p v) - end - | Branch l o r => - match x with - | xH => Branch l v r - | xI p => Branch l o (vm_add p v r) - | xO p => Branch (vm_add p v l) o r - end - end. - - -End MakeVarMap. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v deleted file mode 100644 index 08f3f39204..0000000000 --- a/plugins/micromega/ZCoeff.v +++ /dev/null @@ -1,175 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import ZArith_base. -Require Import InitialRing. -Require Import Setoid. -Require Import ZArithRing. - -Import OrderedRingSyntax. - -Set Implicit Arguments. - -Section InitialMorphism. - -Variable R : Type. -Variables rO rI : R. -Variables rplus rtimes rminus: R -> R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Lemma req_refl : forall x, req x x. -Proof. - destruct (SORsetoid sor) as (Equivalence_Reflexive,_,_). - apply Equivalence_Reflexive. -Qed. - -Lemma req_sym : forall x y, req x y -> req y x. -Proof. - destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_). - apply Equivalence_Symmetric. -Qed. - -Lemma req_trans : forall x y z, req x y -> req y z -> req x z. -Proof. - destruct (SORsetoid sor) as (_,_,Equivalence_Transitive). - apply Equivalence_Transitive. -Qed. - - -Add Relation R req - reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) - symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) - transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) -as sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact (SORplus_wd sor). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact (SORtimes_wd sor). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact (SORopp_wd sor). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact (SORle_wd sor). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact (SORlt_wd sor). -Qed. -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). -Qed. - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. - -Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. -Declare Equivalent Keys gen_order_phi_Z gen_phiZ. - -Notation phi_pos := (gen_phiPOS 1 rplus rtimes). -Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). - -Notation "[ x ]" := (gen_order_phi_Z x). - -Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. -Proof. -constructor. -exact rplus_morph. -exact rtimes_morph. -exact ropp_morph. -Qed. - -Lemma Zring_morph : - ring_morph 0 1 rplus rtimes rminus ropp req - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp - Zeq_bool gen_order_phi_Z. -Proof. -exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)). -Qed. - -Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. -Proof. -induction x as [x IH | x IH |]; simpl; -try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); -try apply (Rlt_0_1 sor); assumption. -Qed. - -Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. -Proof. -exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd - (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))). -Qed. - -Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. -Proof. -intros x y H. pattern y; apply Pos.lt_ind with x. -rewrite phi_pos1_succ; apply (Rlt_succ_r sor). -clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). -assumption. -Qed. - -Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. -Proof. -intros x y H. -do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor)); -destruct x; destruct y; simpl in *; try discriminate. -apply phi_pos1_pos. -now apply clt_pos_morph. -apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. -apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. -apply phi_pos1_pos. -apply -> (Ropp_lt_mono sor); apply clt_pos_morph. -red. now rewrite Pos.compare_antisym. -Qed. - -Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. -Proof. -unfold Z.leb; intros x y H. -case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -le_equal. apply (morph_eq Zring_morph). unfold Zeq_bool; now rewrite H1. -le_less. now apply clt_morph. -discriminate. -Qed. - -Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. -Proof. -intros x y H. unfold Zeq_bool in H. -case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H). -apply (Rlt_neq sor). now apply clt_morph. -fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1. -apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. -Qed. - -End InitialMorphism. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v deleted file mode 100644 index 9bedb47371..0000000000 --- a/plugins/micromega/ZMicromega.v +++ /dev/null @@ -1,1743 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2011 *) -(* *) -(************************************************************************) - -Require Import List. -Require Import Bool. -Require Import OrderedRing. -Require Import RingMicromega. -Require Import ZCoeff. -Require Import Refl. -Require Import ZArith_base. -Require Import ZArithRing. -Require Import Ztac. -Require PreOmega. -(*Declare ML Module "micromega_plugin".*) -Local Open Scope Z_scope. - -Ltac flatten_bool := - repeat match goal with - [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id - | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id - end. - -Ltac inv H := inversion H ; try subst ; clear H. - -Lemma eq_le_iff : forall x, 0 = x <-> (0 <= x /\ x <= 0). -Proof. - intros. - split ; intros. - - subst. - compute. intuition congruence. - - destruct H. - apply Z.le_antisymm; auto. -Qed. - -Lemma lt_le_iff : forall x, - 0 < x <-> 0 <= x - 1. -Proof. - split ; intros. - - apply Zlt_succ_le. - ring_simplify. - auto. - - apply Zle_lt_succ in H. - ring_simplify in H. - auto. -Qed. - -Lemma le_0_iff : forall x y, - x <= y <-> 0 <= y - x. -Proof. - split ; intros. - - apply Zle_minus_le_0; auto. - - apply Zle_0_minus_le; auto. -Qed. - -Lemma le_neg : forall x, - ((0 <= x) -> False) <-> 0 < -x. -Proof. - intro. - rewrite lt_le_iff. - split ; intros. - - apply Znot_le_gt in H. - apply Zgt_le_succ in H. - rewrite le_0_iff in H. - ring_simplify in H; auto. - - assert (C := (Z.add_le_mono _ _ _ _ H H0)). - ring_simplify in C. - compute in C. - apply C ; reflexivity. -Qed. - -Lemma eq_cnf : forall x, - (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0. -Proof. - intros. - rewrite Z.eq_sym_iff. - rewrite eq_le_iff. - rewrite (le_0_iff x 0). - rewrite !le_neg. - rewrite !lt_le_iff. - replace (- (x - 1) -1) with (-x) by ring. - replace (- (-1 - x) -1) with x by ring. - split ; intros (H1 & H2); auto. -Qed. - - - - -Require Import EnvRing. - -Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. -Proof. - constructor ; intros ; subst; try reflexivity. - apply Zsth. - apply Zth. - auto using Z.le_antisymm. - eauto using Z.le_trans. - apply Z.le_neq. - destruct (Z.lt_trichotomy n m) ; intuition. - apply Z.add_le_mono_l; assumption. - apply Z.mul_pos_pos ; auto. - discriminate. -Qed. - -Lemma ZSORaddon : - SORaddon 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le (* ring elements *) - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *) - Zeq_bool Z.leb - (fun x => x) (fun x => x) (pow_N 1 Z.mul). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Zeq_bool_eq ; auto. - constructor. - reflexivity. - intros x y. - apply Zeq_bool_neq ; auto. - apply Zle_bool_imp_le. -Qed. - -Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := - match e with - | PEc c => c - | PEX x => env x - | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 - | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 - | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) - | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) - | PEopp e => Z.opp (Zeval_expr env e) - end. - -Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). - -Fixpoint Zeval_const (e: PExpr Z) : option Z := - match e with - | PEc c => Some c - | PEX x => None - | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) - (Zeval_const e1) (Zeval_const e2) - | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) - (Zeval_const e1) (Zeval_const e2) - | PEpow e1 n => map_option (fun x => Some (Z.pow x (Z.of_N n))) - (Zeval_const e1) - | PEsub e1 e2 => map_option2 (fun x y => Some (x - y)) - (Zeval_const e1) (Zeval_const e2) - | PEopp e => map_option (fun x => Some (Z.opp x)) (Zeval_const e) - end. - -Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. -Proof. - destruct n. - reflexivity. - simpl. - unfold Z.pow_pos. - replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring. - generalize 1. - induction p; simpl ; intros ; repeat rewrite IHp ; ring. -Qed. - -Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. -Proof. - induction e ; simpl ; try congruence. - reflexivity. - rewrite ZNpower. congruence. -Qed. - -Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := -match o with -| OpEq => @eq Z -| OpNEq => fun x y => ~ x = y -| OpLe => Z.le -| OpGe => Z.ge -| OpLt => Z.lt -| OpGt => Z.gt -end. - - -Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= - let (lhs, op, rhs) := f in - (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). - -Definition Zeval_formula' := - eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). - -Lemma Zeval_formula_compat' : forall env f, Zeval_formula env f <-> Zeval_formula' env f. -Proof. - intros. - unfold Zeval_formula. - destruct f. - repeat rewrite Zeval_expr_compat. - unfold Zeval_formula' ; simpl. - unfold eval_expr. - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env Flhs). - generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). - destruct Fop ; simpl; intros; - intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt. -Qed. - - -Definition eval_nformula := - eval_nformula 0 Z.add Z.mul (@eq Z) Z.le Z.lt (fun x => x) . - -Definition Zeval_op1 (o : Op1) : Z -> Prop := -match o with -| Equal => fun x : Z => x = 0 -| NonEqual => fun x : Z => x <> 0 -| Strict => fun x : Z => 0 < x -| NonStrict => fun x : Z => 0 <= x -end. - - -Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). -Proof. - intros. - apply (eval_nformula_dec Zsor). -Qed. - -Definition ZWitness := Psatz Z. - -Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Zeq_bool Z.leb. - -Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), - ZWeakChecker l cm = true -> - forall env, make_impl (eval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold eval_nformula. - apply (checker_nf_sound Zsor ZSORaddon l cm). - unfold ZWeakChecker in H. - exact H. -Qed. - -Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. -Declare Equivalent Keys psub RingMicromega.psub. - -Definition padd := padd Z0 Z.add Zeq_bool. -Declare Equivalent Keys padd RingMicromega.padd. - -Definition pmul := pmul 0 1 Z.add Z.mul Zeq_bool. - -Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. -Declare Equivalent Keys normZ RingMicromega.norm. - -Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). -Declare Equivalent Keys eval_pol RingMicromega.eval_pol. - -Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. -Proof. - intros. - apply (eval_pol_sub Zsor ZSORaddon). -Qed. - -Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs. -Proof. - intros. - apply (eval_pol_add Zsor ZSORaddon). -Qed. - -Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) = eval_pol env lhs * eval_pol env rhs. -Proof. - intros. - apply (eval_pol_mul Zsor ZSORaddon). -Qed. - - -Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . -Proof. - intros. - apply (eval_pol_norm Zsor ZSORaddon). -Qed. - -Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. - -Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. - -Lemma Zunsat_sound : forall f, - Zunsat f = true -> forall env, eval_nformula env f -> False. -Proof. - unfold Zunsat. - intros. - destruct f. - eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto. -Qed. - -Definition xnnormalise (t : Formula Z) : NFormula Z := - let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in - match o with - | OpEq => (psub rhs lhs, Equal) - | OpNEq => (psub rhs lhs, NonEqual) - | OpGt => (psub lhs rhs, Strict) - | OpLt => (psub rhs lhs, Strict) - | OpGe => (psub lhs rhs, NonStrict) - | OpLe => (psub rhs lhs, NonStrict) - end. - -Lemma xnnormalise_correct : - forall env f, - eval_nformula env (xnnormalise f) <-> Zeval_formula env f. -Proof. - intros. - rewrite Zeval_formula_compat'. - unfold xnnormalise. - destruct f as [lhs o rhs]. - destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; - rewrite <- !eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros. - - split ; intros. - + assert (z0 + (z - z0) = z0 + 0) by congruence. - rewrite Z.add_0_r in H0. - rewrite <- H0. - ring. - + subst. - ring. - - split ; repeat intro. - subst. apply H. ring. - apply H. - assert (z0 + (z - z0) = z0 + 0) by congruence. - rewrite Z.add_0_r in H1. - rewrite <- H1. - ring. - - split ; intros. - + apply Zle_0_minus_le; auto. - + apply Zle_minus_le_0; auto. - - split ; intros. - + apply Zle_0_minus_le; auto. - + apply Zle_minus_le_0; auto. - - split ; intros. - + apply Zlt_0_minus_lt; auto. - + apply Zlt_left_lt in H. - apply H. - - split ; intros. - + apply Zlt_0_minus_lt ; auto. - + apply Zlt_left_lt in H. - apply H. -Qed. - -Definition xnormalise (f: NFormula Z) : list (NFormula Z) := - let (e,o) := f in - match o with - | Equal => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil - | NonStrict => ((psub (Pc (-1)) e,NonStrict)::nil) - | Strict => ((psub (Pc 0)) e, NonStrict)::nil - | NonEqual => (e, Equal)::nil - end. - -Lemma eval_pol_Pc : forall env z, - eval_pol env (Pc z) = z. -Proof. - reflexivity. -Qed. - -Ltac iff_ring := - match goal with - | |- ?F 0 ?X <-> ?F 0 ?Y => replace X with Y by ring ; tauto - end. - - -Lemma xnormalise_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. -Proof. - intros. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - generalize (eval_pol env e) as x; intro. - - apply eq_cnf. - - unfold not. tauto. - - rewrite le_neg. - iff_ring. - - rewrite le_neg. - rewrite lt_le_iff. - iff_ring. -Qed. - - -Require Import Coq.micromega.Tauto BinNums. - -Definition cnf_of_list {T: Type} (tg : T) (l : list (NFormula Z)) := - List.fold_right (fun x acc => - if Zunsat x then acc else ((x,tg)::nil)::acc) - (cnf_tt _ _) l. - -Lemma cnf_of_list_correct : - forall {T : Type} (tg:T) (f : list (NFormula Z)) env, - eval_cnf eval_nformula env (cnf_of_list tg f) <-> - make_conj (fun x : NFormula Z => eval_nformula env x -> False) f. -Proof. - unfold cnf_of_list. - intros. - set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) => - if Zunsat x then acc else ((x, tg) :: nil) :: acc)). - set (E := ((fun x : NFormula Z => eval_nformula env x -> False))). - induction f. - - compute. - tauto. - - rewrite make_conj_cons. - simpl. - unfold F at 1. - destruct (Zunsat a) eqn:EQ. - + rewrite IHf. - unfold E at 1. - specialize (Zunsat_sound _ EQ env). - tauto. - + - rewrite <- eval_cnf_cons_iff. - rewrite IHf. - simpl. - unfold E at 2. - unfold eval_tt. simpl. - tauto. -Qed. - -Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - let f := xnnormalise t in - if Zunsat f then cnf_ff _ _ - else cnf_of_list tg (xnormalise f). - -Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. -Proof. - intros. - rewrite <- xnnormalise_correct. - unfold normalise. - generalize (xnnormalise t) as f;intro. - destruct (Zunsat f) eqn:U. - - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_ff. - tauto. - - rewrite cnf_of_list_correct. - apply xnormalise_correct. -Qed. - -Definition xnegate (f:NFormula Z) : list (NFormula Z) := - let (e,o) := f in - match o with - | Equal => (e,Equal) :: nil - | NonEqual => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil - | NonStrict => (e,NonStrict)::nil - | Strict => (psub e (Pc 1),NonStrict)::nil - end. - -Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - let f := xnnormalise t in - if Zunsat f then cnf_tt _ _ - else cnf_of_list tg (xnegate f). - -Lemma xnegate_correct : forall env f, - (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. -Proof. - intros. - destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; - repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; - generalize (eval_pol env e) as x; intro. - - tauto. - - rewrite eq_cnf. - destruct (Z.eq_decidable x 0);tauto. - - rewrite lt_le_iff. - tauto. - - tauto. -Qed. - -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. -Proof. - intros. - rewrite <- xnnormalise_correct. - unfold negate. - generalize (xnnormalise t) as f;intro. - destruct (Zunsat f) eqn:U. - - assert (US := Zunsat_sound _ U env). - rewrite eval_cnf_tt. - tauto. - - rewrite cnf_of_list_correct. - apply xnegate_correct. -Qed. - -Definition cnfZ (Annot: Type) (TX : Type) (AF : Type) (f : TFormula (Formula Z) Annot TX AF) := - rxcnf Zunsat Zdeduce normalise negate true f. - -Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. - -(* To get a complete checker, the proof format has to be enriched *) - -Require Import Zdiv. -Local Open Scope Z_scope. - -Definition ceiling (a b:Z) : Z := - let (q,r) := Z.div_eucl a b in - match r with - | Z0 => q - | _ => q + 1 - end. - - -Require Import Znumtheory. - -Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. -Proof. - unfold ceiling. - intros. - apply Zdivide_mod in H. - case_eq (Z.div_eucl a b). - intros. - change z with (fst (z,z0)). - rewrite <- H0. - change (fst (Z.div_eucl a b)) with (Z.div a b). - change z0 with (snd (z,z0)). - rewrite <- H0. - change (snd (Z.div_eucl a b)) with (Z.modulo a b). - rewrite H. - reflexivity. -Qed. - -Lemma narrow_interval_lower_bound a b x : - a > 0 -> a * x >= b -> x >= ceiling b a. -Proof. - rewrite !Z.ge_le_iff. - unfold ceiling. - intros Ha H. - generalize (Z_div_mod b a Ha). - destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)). - destruct r as [|r|r]. - - rewrite Z.add_0_r in H. - apply Z.mul_le_mono_pos_l in H; auto with zarith. - - assert (0 < Z.pos r) by easy. - rewrite Z.add_1_r, Z.le_succ_l. - apply Z.mul_lt_mono_pos_l with a. - auto using Z.gt_lt. - eapply Z.lt_le_trans. 2: eassumption. - now apply Z.lt_add_pos_r. - - now elim H1. -Qed. - -(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) - -Require Import QArith. - -Inductive ZArithProof := -| DoneProof -| RatProof : ZWitness -> ZArithProof -> ZArithProof -| CutProof : ZWitness -> ZArithProof -> ZArithProof -| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -| ExProof : positive -> ZArithProof -> ZArithProof -(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) -. -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) - - - -(* n/d <= x -> d*x - n >= 0 *) - - -(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - - b is the constant - - a is the gcd of the other coefficient. -*) -Require Import Znumtheory. - -Definition isZ0 (x:Z) := - match x with - | Z0 => true - | _ => false - end. - -Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. -Proof. - destruct x ; simpl ; intuition congruence. -Qed. - -Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. -Proof. - destruct x ; simpl ; intuition congruence. -Qed. - -Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. - - -Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := - match p with - | Pc c => (0,c) - | Pinj _ p => Zgcd_pol p - | PX p _ q => - let (g1,c1) := Zgcd_pol p in - let (g2,c2) := Zgcd_pol q in - (ZgcdM (ZgcdM g1 c1) g2 , c2) - end. - -(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*) - - -Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := - match p with - | Pc c => Pc (Z.div c x) - | Pinj j p => Pinj j (Zdiv_pol p x) - | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) - end. - -Inductive Zdivide_pol (x:Z): PolC Z -> Prop := -| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c) -| Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p) -| Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). - - -Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> - forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). -Proof. - intros until 2. - induction H0. - (* Pc *) - simpl. - intros. - apply Zdivide_Zdiv_eq ; auto. - (* Pinj *) - simpl. - intros. - apply IHZdivide_pol. - (* PX *) - simpl. - intros. - rewrite IHZdivide_pol1. - rewrite IHZdivide_pol2. - ring. -Qed. - -Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. -Proof. - induction p. 1-2: easy. - simpl. - case_eq (Zgcd_pol p1). - case_eq (Zgcd_pol p3). - intros. - simpl. - unfold ZgcdM. - apply Z.le_ge; transitivity 1. easy. - apply Z.le_max_r. -Qed. - -Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. -Proof. - intros. - induction H. - constructor. - apply Z.divide_trans with (1:= H0) ; assumption. - constructor. auto. - constructor ; auto. -Qed. - -Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. -Proof. - induction p ; constructor ; auto. - exists c. ring. -Qed. - -Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c). -Proof. - intros a b c (q,Hq). - destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. - set (g:=Z.gcd a b) in *; clearbody g. - exists (q * a' + b'). - symmetry in Hq. rewrite <- Z.add_move_r in Hq. - rewrite <- Hq, Hb, Ha. ring. -Qed. - -Lemma Zdivide_pol_sub : forall p a b, - 0 < Z.gcd a b -> - Zdivide_pol a (PsubC Z.sub p b) -> - Zdivide_pol (Z.gcd a b) p. -Proof. - induction p. - simpl. - intros. inversion H0. - constructor. - apply Zgcd_minus ; auto. - intros. - constructor. - simpl in H0. inversion H0 ; subst; clear H0. - apply IHp ; auto. - simpl. intros. - inv H0. - constructor. - apply Zdivide_pol_Zdivide with (1:= H3). - destruct (Zgcd_is_gcd a b) ; assumption. - apply IHp2 ; assumption. -Qed. - -Lemma Zdivide_pol_sub_0 : forall p a, - Zdivide_pol a (PsubC Z.sub p 0) -> - Zdivide_pol a p. -Proof. - induction p. - simpl. - intros. inversion H. - constructor. rewrite Z.sub_0_r in *. assumption. - intros. - constructor. - simpl in H. inversion H ; subst; clear H. - apply IHp ; auto. - simpl. intros. - inv H. - constructor. auto. - apply IHp2 ; assumption. -Qed. - - -Lemma Zgcd_pol_div : forall p g c, - Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). -Proof. - induction p ; simpl. - (* Pc *) - intros. inv H. - constructor. - exists 0. now ring. - (* Pinj *) - intros. - constructor. apply IHp ; auto. - (* PX *) - intros g c. - case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. - inv H1. - unfold ZgcdM at 1. - destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; - destruct HH1 as [HH1 HH1'] ; rewrite HH1'. - constructor. - apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). - unfold ZgcdM. - destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. - destruct HH2. - rewrite H2. - apply Zdivide_pol_sub ; auto. - apply Z.lt_le_trans with 1. reflexivity. now apply Z.ge_le. - destruct HH2. rewrite H2. - apply Zdivide_pol_one. - unfold ZgcdM in HH1. unfold ZgcdM. - destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. - destruct HH2. rewrite H2 in *. - destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. - destruct HH2. rewrite H2. - destruct (Zgcd_is_gcd 1 z); auto. - apply Zdivide_pol_Zdivide with (x:= z). - apply (IHp2 _ _ H); auto. - destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. - constructor. apply Zdivide_pol_one. - apply Zdivide_pol_one. -Qed. - - - - -Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) + c. -Proof. - intros. - rewrite <- Zdiv_pol_correct ; auto. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - unfold eval_pol. ring. - (**) - apply Zgcd_pol_div ; auto. -Qed. - - - -Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := - let (g,c) := Zgcd_pol p in - if Z.gtb g Z0 - then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g)) - else (p,Z0). - - -Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := - let (e,op) := f in - match op with - | Equal => let (g,c) := Zgcd_pol e in - if andb (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd g c) g))) - then None (* inconsistent *) - else (* Could be optimised Zgcd_pol is recomputed *) - let (p,c) := makeCuttingPlane e in - Some (p,c,Equal) - | NonEqual => Some (e,Z0,op) - | Strict => let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in - Some (p,c,NonStrict) - | NonStrict => let (p,c) := makeCuttingPlane e in - Some (p,c,NonStrict) - end. - -Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z := - let (e_z, o) := t in - let (e,z) := e_z in - (padd e (Pc z) , o). - -Definition is_pol_Z0 (p : PolC Z) : bool := - match p with - | Pc Z0 => true - | _ => false - end. - -Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. -Proof. - unfold is_pol_Z0. - destruct p ; try discriminate. - destruct z ; try discriminate. - reflexivity. -Qed. - - -Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := - eval_Psatz 0 1 Z.add Z.mul Zeq_bool Z.leb. - - -Definition valid_cut_sign (op:Op1) := - match op with - | Equal => true - | NonStrict => true - | _ => false - end. - - -Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX v) OpGe (PEc 0). - -Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := - Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). - - -Fixpoint vars (jmp : positive) (p : Pol Z) : list positive := - match p with - | Pc c => nil - | Pinj j p => vars (Pos.add j jmp) p - | PX p j q => jmp::(vars jmp p)++vars (Pos.succ jmp) q - end. - -Fixpoint max_var (jmp : positive) (p : Pol Z) : positive := - match p with - | Pc _ => jmp - | Pinj j p => max_var (Pos.add j jmp) p - | PX p j q => Pos.max (max_var jmp p) (max_var (Pos.succ jmp) q) - end. - -Lemma pos_le_add : forall y x, - (x <= y + x)%positive. -Proof. - intros. - assert ((Z.pos x) <= Z.pos (x + y))%Z. - rewrite <- (Z.add_0_r (Zpos x)). - rewrite <- Pos2Z.add_pos_pos. - apply Z.add_le_mono_l. - compute. congruence. - rewrite Pos.add_comm in H. - apply H. -Qed. - - -Lemma max_var_le : forall p v, - (v <= max_var v p)%positive. -Proof. - induction p; simpl. - - intros. - apply Pos.le_refl. - - intros. - specialize (IHp (p+v)%positive). - eapply Pos.le_trans ; eauto. - assert (xH + v <= p + v)%positive. - { apply Pos.add_le_mono. - apply Pos.le_1_l. - apply Pos.le_refl. - } - eapply Pos.le_trans ; eauto. - apply pos_le_add. - - intros. - apply Pos.max_case_strong;intros ; auto. - specialize (IHp2 (Pos.succ v)%positive). - eapply Pos.le_trans ; eauto. -Qed. - -Lemma max_var_correct : forall p j v, - In v (vars j p) -> Pos.le v (max_var j p). -Proof. - induction p; simpl. - - tauto. - - auto. - - intros. - rewrite in_app_iff in H. - destruct H as [H |[ H | H]]. - + subst. - apply Pos.max_case_strong;intros ; auto. - apply max_var_le. - eapply Pos.le_trans ; eauto. - apply max_var_le. - + apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - + apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. -Qed. - -Definition max_var_nformulae (l : list (NFormula Z)) := - List.fold_left (fun acc f => Pos.max acc (max_var xH (fst f))) l xH. - -Section MaxVar. - - Definition F (acc : positive) (f : Pol Z * Op1) := Pos.max acc (max_var 1 (fst f)). - - Lemma max_var_nformulae_mono_aux : - forall l v acc, - (v <= acc -> - v <= fold_left F l acc)%positive. - Proof. - induction l ; simpl ; [easy|]. - intros. - apply IHl. - unfold F. - apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - Qed. - - Lemma max_var_nformulae_mono_aux' : - forall l acc acc', - (acc <= acc' -> - fold_left F l acc <= fold_left F l acc')%positive. - Proof. - induction l ; simpl ; [easy|]. - intros. - apply IHl. - unfold F. - apply Pos.max_le_compat_r; auto. - Qed. - - - - - Lemma max_var_nformulae_correct_aux : forall l p o v, - In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive. - Proof. - intros. - generalize 1%positive as acc. - revert p o v H H0. - induction l. - - simpl. tauto. - - simpl. - intros. - destruct H ; subst. - + unfold F at 2. - simpl. - apply max_var_correct in H0. - apply max_var_nformulae_mono_aux. - apply Pos.max_case_strong;intros ; auto. - eapply Pos.le_trans ; eauto. - + eapply IHl ; eauto. - Qed. - -End MaxVar. - -Lemma max_var_nformalae_correct : forall l p o v, - In (p,o) l -> In v (vars xH p) -> Pos.le v (max_var_nformulae l)%positive. -Proof. - intros l p o v. - apply max_var_nformulae_correct_aux. -Qed. - - -Fixpoint max_var_psatz (w : Psatz Z) : positive := - match w with - | PsatzIn _ n => xH - | PsatzSquare p => max_var xH (Psquare 0 1 Z.add Z.mul Zeq_bool p) - | PsatzMulC p w => Pos.max (max_var xH p) (max_var_psatz w) - | PsatzMulE w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) - | PsatzAdd w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2) - | _ => xH - end. - -Fixpoint max_var_prf (w : ZArithProof) : positive := - match w with - | DoneProof => xH - | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf) - | EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l - (Pos.max (max_var_psatz w1) (max_var_psatz w2)) - | ExProof _ pf => max_var_prf pf - end. - - - -Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := - match pf with - | DoneProof => false - | RatProof w pf => - match eval_Psatz l w with - | None => false - | Some f => - if Zunsat f then true - else ZChecker (f::l) pf - end - | CutProof w pf => - match eval_Psatz l w with - | None => false - | Some f => - match genCuttingPlane f with - | None => true - | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf - end - end - | ExProof x prf => - let fr := max_var_nformulae l in - if Pos.leb x fr then - let z := Pos.succ fr in - let t := Pos.succ z in - let nfx := xnnormalise (mk_eq_pos x z t) in - let posz := xnnormalise (bound_var z) in - let post := xnnormalise (bound_var t) in - ZChecker (nfx::posz::post::l) prf - else false - | EnumProof w1 w2 pf => - match eval_Psatz l w1 , eval_Psatz l w2 with - | Some f1 , Some f2 => - match genCuttingPlane f1 , genCuttingPlane f2 with - |Some (e1,z1,op1) , Some (e2,z2,op2) => - if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2)) - then - (fix label (pfs:list ZArithProof) := - fun lb ub => - match pfs with - | nil => if Z.gtb lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) - end) pf (Z.opp z1) z2 - else false - | _ , _ => true - end - | _ , _ => false - end -end. - - - -Fixpoint bdepth (pf : ZArithProof) : nat := - match pf with - | DoneProof => O - | RatProof _ p => S (bdepth p) - | CutProof _ p => S (bdepth p) - | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) - | ExProof _ p => S (bdepth p) - end. - -Require Import Wf_nat. - -Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). -Proof. - induction l. - (* nil *) - simpl. - tauto. - (* cons *) - simpl. - intros. - destruct H. - subst. - unfold ltof. - simpl. - generalize ( (fold_right - (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). - intros. - generalize (bdepth y) ; intros. - rewrite Nat.lt_succ_r. apply Nat.le_max_l. - generalize (IHl a0 b y H). - unfold ltof. - simpl. - generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat - l)). - intros. - eapply lt_le_trans. eassumption. - rewrite <- Nat.succ_le_mono. - apply Nat.le_max_r. -Qed. - - -Lemma eval_Psatz_sound : forall env w l f', - make_conj (eval_nformula env) l -> - eval_Psatz l w = Some f' -> eval_nformula env f'. -Proof. - intros. - apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. - apply make_conj_in ; auto. -Qed. - -Lemma makeCuttingPlane_ns_sound : forall env e e' c, - eval_nformula env (e, NonStrict) -> - makeCuttingPlane e = (e',c) -> - eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). -Proof. - unfold nformula_of_cutting_plane. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - unfold eval_op1. - intros. - rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. - (**) - unfold makeCuttingPlane in H0. - revert H0. - case_eq (Zgcd_pol e) ; intros g c0. - generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0). - intros. - inv H2. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. - apply Zgcd_pol_correct_lt with (env:=env) in H1. 2: auto using Z.gt_lt. - apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r. - apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). - apply Z.le_ge. - rewrite <- Z.sub_0_l. - apply Z.le_sub_le_add_r. - rewrite <- H1. - assumption. - (* g <= 0 *) - intros. inv H2. auto with zarith. -Qed. - -Lemma cutting_plane_sound : forall env f p, - eval_nformula env f -> - genCuttingPlane f = Some p -> - eval_nformula env (nformula_of_cutting_plane p). -Proof. - unfold genCuttingPlane. - destruct f as [e op]. - destruct op. - (* Equal *) - destruct p as [[e' z] op]. - case_eq (Zgcd_pol e) ; intros g c. - case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|]. - case_eq (makeCuttingPlane e). - intros. - inv H3. - unfold makeCuttingPlane in H. - rewrite H1 in H. - revert H. - change (eval_pol env e = 0) in H2. - case_eq (Z.gtb g 0). - intros. - rewrite <- Zgt_is_gt_bool in H. - rewrite Zgcd_pol_correct_lt with (1:= H1) in H2. 2: auto using Z.gt_lt. - unfold nformula_of_cutting_plane. - change (eval_pol env (padd e' (Pc z)) = 0). - inv H3. - rewrite eval_pol_add. - set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. - simpl. - rewrite andb_false_iff in H0. - destruct H0. - rewrite Zgt_is_gt_bool in H ; congruence. - rewrite andb_false_iff in H0. - destruct H0. - rewrite negb_false_iff in H0. - apply Zeq_bool_eq in H0. - subst. simpl. - rewrite Z.add_0_r, Z.mul_eq_0 in H2. - intuition subst; easy. - rewrite negb_false_iff in H0. - apply Zeq_bool_eq in H0. - assert (HH := Zgcd_is_gcd g c). - rewrite H0 in HH. - inv HH. - apply Zdivide_opp_r in H4. - rewrite Zdivide_ceiling ; auto. - apply Z.sub_move_0_r. - apply Z.div_unique_exact. now intros ->. - now rewrite Z.add_move_0_r in H2. - intros. - unfold nformula_of_cutting_plane. - inv H3. - change (eval_pol env (padd e' (Pc 0)) = 0). - rewrite eval_pol_add. - simpl. - now rewrite Z.add_0_r. - (* NonEqual *) - intros. - inv H0. - unfold eval_nformula in *. - unfold RingMicromega.eval_nformula in *. - unfold nformula_of_cutting_plane. - unfold eval_op1 in *. - rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. now rewrite Z.add_0_r. - (* Strict *) - destruct p as [[e' z] op]. - case_eq (makeCuttingPlane (PsubC Z.sub e 1)). - intros. - inv H1. - apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). - simpl in *. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - now apply Z.lt_le_pred. - (* NonStrict *) - destruct p as [[e' z] op]. - case_eq (makeCuttingPlane e). - intros. - inv H1. - apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). - assumption. -Qed. - -Lemma genCuttingPlaneNone : forall env f, - genCuttingPlane f = None -> - eval_nformula env f -> False. -Proof. - unfold genCuttingPlane. - destruct f. - destruct o. - case_eq (Zgcd_pol p) ; intros g c. - case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))). - intros. - flatten_bool. - rewrite negb_true_iff in H5. - apply Zeq_bool_neq in H5. - rewrite <- Zgt_is_gt_bool in H3. - rewrite negb_true_iff in H. - apply Zeq_bool_neq in H. - change (eval_pol env p = 0) in H2. - rewrite Zgcd_pol_correct_lt with (1:= H0) in H2. 2: auto using Z.gt_lt. - set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. - contradict H5. - apply Zis_gcd_gcd. apply Z.lt_le_incl, Z.gt_lt; assumption. - constructor; auto with zarith. - exists (-x). - rewrite Z.mul_opp_l, Z.mul_comm. - now apply Z.add_move_0_l. - (**) - destruct (makeCuttingPlane p); discriminate. - discriminate. - destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate. - destruct (makeCuttingPlane p) ; discriminate. -Qed. - -Lemma eval_nformula_mk_eq_pos : forall env x z t, - env x = env z - env t -> - eval_nformula env (xnnormalise (mk_eq_pos x z t)). -Proof. - intros. - rewrite xnnormalise_correct. - simpl. auto. -Qed. - -Lemma eval_nformula_bound_var : forall env x, - env x >= 0 -> - eval_nformula env (xnnormalise (bound_var x)). -Proof. - intros. - rewrite xnnormalise_correct. - simpl. auto. -Qed. - - -Definition agree_env (fr : positive) (env env' : positive -> Z) : Prop := - forall x, Pos.le x fr -> env x = env' x. - -Lemma agree_env_subset : forall v1 v2 env env', - agree_env v1 env env' -> - Pos.le v2 v1 -> - agree_env v2 env env'. -Proof. - unfold agree_env. - intros. - apply H. - eapply Pos.le_trans ; eauto. -Qed. - - -Lemma agree_env_jump : forall fr j env env', - agree_env (fr + j) env env' -> - agree_env fr (Env.jump j env) (Env.jump j env'). -Proof. - intros. - unfold agree_env ; intro. - intros. - unfold Env.jump. - apply H. - apply Pos.add_le_mono_r; auto. -Qed. - - -Lemma agree_env_tail : forall fr env env', - agree_env (Pos.succ fr) env env' -> - agree_env fr (Env.tail env) (Env.tail env'). -Proof. - intros. - unfold Env.tail. - apply agree_env_jump. - rewrite <- Pos.add_1_r in H. - apply H. -Qed. - - -Lemma max_var_acc : forall p i j, - (max_var (i + j) p = max_var i p + j)%positive. -Proof. - induction p; simpl. - - reflexivity. - - intros. - rewrite ! IHp. - rewrite Pos.add_assoc. - reflexivity. - - intros. - rewrite !Pplus_one_succ_l. - rewrite ! IHp1. - rewrite ! IHp2. - rewrite ! Pos.add_assoc. - rewrite <- Pos.add_max_distr_r. - reflexivity. -Qed. - - - -Lemma agree_env_eval_nformula : - forall env env' e - (AGREE : agree_env (max_var xH (fst e)) env env'), - eval_nformula env e <-> eval_nformula env' e. -Proof. - destruct e. - simpl; intros. - assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p) - = - (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)). - { - revert env env' AGREE. - generalize xH. - induction p ; simpl. - - reflexivity. - - intros. - apply IHp with (p := p1%positive). - apply agree_env_jump. - eapply agree_env_subset; eauto. - rewrite (Pos.add_comm p). - rewrite max_var_acc. - apply Pos.le_refl. - - intros. - f_equal. - f_equal. - { apply IHp1 with (p:= p). - eapply agree_env_subset; eauto. - apply Pos.le_max_l. - } - f_equal. - { unfold Env.hd. - unfold Env.nth. - apply AGREE. - apply Pos.le_1_l. - } - { - apply IHp2 with (p := p). - apply agree_env_tail. - eapply agree_env_subset; eauto. - rewrite !Pplus_one_succ_r. - rewrite max_var_acc. - apply Pos.le_max_r. - } - } - rewrite H. tauto. -Qed. - -Lemma agree_env_eval_nformulae : - forall env env' l - (AGREE : agree_env (max_var_nformulae l) env env'), - make_conj (eval_nformula env) l <-> - make_conj (eval_nformula env') l. -Proof. - induction l. - - simpl. tauto. - - intros. - rewrite ! make_conj_cons. - assert (eval_nformula env a <-> eval_nformula env' a). - { - apply agree_env_eval_nformula. - eapply agree_env_subset ; eauto. - unfold max_var_nformulae. - simpl. - rewrite Pos.max_1_l. - apply max_var_nformulae_mono_aux. - apply Pos.le_refl. - } - rewrite H. - apply and_iff_compat_l. - apply IHl. - eapply agree_env_subset ; eauto. - unfold max_var_nformulae. - simpl. - apply max_var_nformulae_mono_aux'. - apply Pos.le_1_l. -Qed. - - -Lemma eq_true_iff_eq : - forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2. -Proof. - destruct b1,b2 ; intuition congruence. -Qed. - -Ltac pos_tac := - repeat - match goal with - | |- false = _ => symmetry - | |- Pos.eqb ?X ?Y = false => rewrite Pos.eqb_neq ; intro - | H : @eq positive ?X ?Y |- _ => apply Zpos_eq in H - | H : context[Z.pos (Pos.succ ?X)] |- _ => rewrite (Pos2Z.inj_succ X) in H - | H : Pos.leb ?X ?Y = true |- _ => rewrite Pos.leb_le in H ; - apply (Pos2Z.pos_le_pos X Y) in H - end. - -Lemma ZChecker_sound : forall w l, - ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. -Proof. - induction w using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w as [ | w pf | w pf | w1 w2 pf | x pf]. - - (* DoneProof *) - simpl. discriminate. - - (* RatProof *) - simpl. - intros l. case_eq (eval_Psatz l w) ; [| discriminate]. - intros f Hf. - case_eq (Zunsat f). - intros. - apply (checker_nf_sound Zsor ZSORaddon l w). - unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. - unfold Zunsat in H0. assumption. - intros. - assert (make_impl (eval_nformula env) (f::l) False). - apply H with (2:= H1). - unfold ltof. - simpl. - auto with arith. - destruct f. - rewrite <- make_conj_impl in H2. - rewrite make_conj_cons in H2. - rewrite <- make_conj_impl. - intro. - apply H2. - split ; auto. - apply eval_Psatz_sound with (2:= Hf) ; assumption. - - (* CutProof *) - simpl. - intros l. - case_eq (eval_Psatz l w) ; [ | discriminate]. - intros f' Hlc. - case_eq (genCuttingPlane f'). - intros. - assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). - eapply (H pf) ; auto. - unfold ltof. - simpl. - auto with arith. - rewrite <- make_conj_impl in H2. - rewrite make_conj_cons in H2. - rewrite <- make_conj_impl. - intro. - apply H2. - split ; auto. - apply eval_Psatz_sound with (env:=env) in Hlc. - apply cutting_plane_sound with (1:= Hlc) (2:= H0). - auto. - (* genCuttingPlane = None *) - intros. - rewrite <- make_conj_impl. - intros. - apply eval_Psatz_sound with (2:= Hlc) in H2. - apply genCuttingPlaneNone with (2:= H2) ; auto. - - (* EnumProof *) - intros l. - simpl. - case_eq (eval_Psatz l w1) ; [ | discriminate]. - case_eq (eval_Psatz l w2) ; [ | discriminate]. - intros f1 Hf1 f2 Hf2. - case_eq (genCuttingPlane f2). - destruct p as [ [p1 z1] op1]. - case_eq (genCuttingPlane f1). - destruct p as [ [p2 z2] op2]. - case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). - intros Hcond. - flatten_bool. - rename H1 into HZ0. - rename H2 into Hop1. - rename H3 into Hop2. - intros HCutL HCutR Hfix env. - (* get the bounds of the enum *) - rewrite <- make_conj_impl. - intro. - assert (-z1 <= eval_pol env p1 <= z2). - split. - apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. - apply cutting_plane_sound with (1:= Hf2) in HCutR. - unfold nformula_of_cutting_plane in HCutR. - unfold eval_nformula in HCutR. - unfold RingMicromega.eval_nformula in HCutR. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. - unfold eval_op1 in HCutR. - destruct op1 ; simpl in Hop1 ; try discriminate; - rewrite eval_pol_add in HCutR; simpl in HCutR. - rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity. - now apply Z.le_sub_le_add_r in HCutR. - (**) - apply is_pol_Z0_eval_pol with (env := env) in HZ0. - rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0. - rewrite HZ0. - apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. - apply cutting_plane_sound with (1:= Hf1) in HCutL. - unfold nformula_of_cutting_plane in HCutL. - unfold eval_nformula in HCutL. - unfold RingMicromega.eval_nformula in HCutL. - change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. - unfold eval_op1 in HCutL. - rewrite eval_pol_add in HCutL. simpl in HCutL. - destruct op2 ; simpl in Hop2 ; try discriminate. - rewrite Z.add_move_r, Z.sub_0_l in HCutL. - now rewrite HCutL, Z.opp_involutive. - now rewrite <- Z.le_sub_le_add_l in HCutL. - revert Hfix. - match goal with - | |- context[?F pf (-z1) z2 = true] => set (FF := F) - end. - intros. - assert (HH :forall x, -z1 <= x <= z2 -> exists pr, - (In pr pf /\ - ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). - clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. - revert Hfix. - generalize (-z1). clear z1. intro z1. - revert z1 z2. - induction pf;simpl ;intros. - revert Hfix. - now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zlt_not_le _ _ LT); transitivity x. - flatten_bool. - destruct (Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ]. - 2: exists a; auto. - rewrite <- Z.le_succ_l in LT. - assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition. - elim IHpf with (2:=H2) (3:= LE). - intros. - exists x0 ; split;tauto. - intros until 1. - apply H ; auto. - unfold ltof in *. - simpl in *. - PreOmega.zify. - intuition subst. assumption. - eapply Z.lt_le_trans. eassumption. - apply Z.add_le_mono_r. assumption. - (*/asser *) - destruct (HH _ H1) as [pr [Hin Hcheker]]. - assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). - eapply (H pr) ;auto. - apply in_bdepth ; auto. - rewrite <- make_conj_impl in H2. - apply H2. - rewrite make_conj_cons. - split ;auto. - unfold eval_nformula. - unfold RingMicromega.eval_nformula. - simpl. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - unfold eval_pol. ring. - discriminate. - (* No cutting plane *) - intros. - rewrite <- make_conj_impl. - intros. - apply eval_Psatz_sound with (2:= Hf1) in H3. - apply genCuttingPlaneNone with (2:= H3) ; auto. - (* No Cutting plane (bis) *) - intros. - rewrite <- make_conj_impl. - intros. - apply eval_Psatz_sound with (2:= Hf2) in H2. - apply genCuttingPlaneNone with (2:= H2) ; auto. -- intros l. - unfold ZChecker. - fold ZChecker. - set (fr := (max_var_nformulae l)%positive). - set (z1 := (Pos.succ fr)) in *. - set (t1 := (Pos.succ z1)) in *. - destruct (x <=? fr)%positive eqn:LE ; [|congruence]. - intros. - set (env':= fun v => if Pos.eqb v z1 - then if Z.leb (env x) 0 then 0 else env x - else if Pos.eqb v t1 - then if Z.leb (env x) 0 then -(env x) else 0 - else env v). - apply H with (env:=env') in H0. - + rewrite <- make_conj_impl in *. - intro. - rewrite !make_conj_cons in H0. - apply H0 ; repeat split. - * - apply eval_nformula_mk_eq_pos. - unfold env'. - rewrite! Pos.eqb_refl. - replace (x=?z1)%positive with false. - replace (x=?t1)%positive with false. - replace (t1=?z1)%positive with false. - destruct (env x <=? 0); ring. - { unfold t1. - pos_tac; normZ. - lia (Hyp H2). - } - { - unfold t1, z1. - pos_tac; normZ. - lia (Add (Hyp LE) (Hyp H3)). - } - { - unfold z1. - pos_tac; normZ. - lia (Add (Hyp LE) (Hyp H3)). - } - * - apply eval_nformula_bound_var. - unfold env'. - rewrite! Pos.eqb_refl. - destruct (env x <=? 0) eqn:EQ. - compute. congruence. - rewrite Z.leb_gt in EQ. - normZ. - lia (Add (Hyp EQ) (Hyp H2)). - * - apply eval_nformula_bound_var. - unfold env'. - rewrite! Pos.eqb_refl. - replace (t1 =? z1)%positive with false. - destruct (env x <=? 0) eqn:EQ. - rewrite Z.leb_le in EQ. - normZ. - lia (Add (Hyp EQ) (Hyp H2)). - compute; congruence. - unfold t1. - clear. - pos_tac; normZ. - lia (Hyp H). - * - rewrite agree_env_eval_nformulae with (env':= env') in H1;auto. - unfold agree_env; intros. - unfold env'. - replace (x0 =? z1)%positive with false. - replace (x0 =? t1)%positive with false. - reflexivity. - { - unfold t1, z1. - unfold fr in *. - apply Pos2Z.pos_le_pos in H2. - pos_tac; normZ. - lia (Add (Hyp H2) (Hyp H4)). - } - { - unfold z1, fr in *. - apply Pos2Z.pos_le_pos in H2. - pos_tac; normZ. - lia (Add (Hyp H2) (Hyp H4)). - } - + unfold ltof. - simpl. - apply Nat.lt_succ_diag_r. -Qed. - - - -Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. - -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f. -Proof. - intros f w. - unfold ZTautoChecker. - apply tauto_checker_sound with (eval' := eval_nformula). - - apply Zeval_nformula_dec. - - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - - unfold Zdeduce. intros. revert H. - apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - - - intros. - rewrite normalise_correct in H. - auto. - - - intros. - rewrite negate_correct in H ; auto. - - intros t w0. - unfold eval_tt. - intros. - rewrite make_impl_map with (eval := eval_nformula env). - eapply ZChecker_sound; eauto. - tauto. -Qed. - - -Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := - match pt with - | DoneProof => acc - | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | EnumProof c1 c2 l => - let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in - List.fold_left (xhyps_of_pt (S base)) l acc - | ExProof _ pt => xhyps_of_pt (S (S (S base ))) acc pt - end. - -Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. - -Open Scope Z_scope. - -(** To ease bindings from ml code **) -Definition make_impl := Refl.make_impl. -Definition make_conj := Refl.make_conj. - -Require VarMap. - -(*Definition varmap_type := VarMap.t Z. *) -Definition env := PolEnv Z. -Definition node := @VarMap.Branch Z. -Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Elt Z. - -Definition coneMember := ZWitness. - -Definition eval := eval_formula. - -Definition prod_pos_nat := prod positive nat. - -Notation n_of_Z := Z.to_N (only parsing). - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) - - diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v deleted file mode 100644 index 18cd196148..0000000000 --- a/plugins/micromega/Zify.v +++ /dev/null @@ -1,90 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import ZifyClasses. -Require Export ZifyInst. -Require Import InitialRing. - -(** From PreOmega *) - -(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) - -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - pose proof (thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -Ltac zify_unop t thm a := - (* If a is a scalar, we can simply reduce the unop. *) - (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) - let isz := isZcst a in - match isz with - | true => - let u := eval compute in (t a) in - change (t a) with u in * - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -(* end from PreOmega *) - -Ltac applySpec S := - let t := type of S in - match t with - | @BinOpSpec _ _ ?Op _ => - let Spec := (eval unfold S, BSpec in (@BSpec _ _ Op _ S)) in - repeat - match goal with - | H : context[Op ?X ?Y] |- _ => zify_binop Op Spec X Y - | |- context[Op ?X ?Y] => zify_binop Op Spec X Y - end - | @UnOpSpec _ _ ?Op _ => - let Spec := (eval unfold S, USpec in (@USpec _ _ Op _ S)) in - repeat - match goal with - | H : context[Op ?X] |- _ => zify_unop Op Spec X - | |- context[Op ?X ] => zify_unop Op Spec X - end - end. - -(** [zify_post_hook] is there to be redefined. *) -Ltac zify_post_hook := idtac. - -Ltac zify := zify_op ; (zify_iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyBool.v b/plugins/micromega/ZifyBool.v deleted file mode 100644 index 4060478363..0000000000 --- a/plugins/micromega/ZifyBool.v +++ /dev/null @@ -1,278 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -Require Import Bool ZArith. -Require Import Zify ZifyClasses. -Local Open Scope Z_scope. -(* Instances of [ZifyClasses] for dealing with boolean operators. - Various encodings of boolean are possible. One objective is to - have an encoding that is terse but also lia friendly. - *) - -(** [Z_of_bool] is the injection function for boolean *) -Definition Z_of_bool (b : bool) : Z := if b then 1 else 0. - -(** [bool_of_Z] is a compatible reverse operation *) -Definition bool_of_Z (z : Z) : bool := negb (Z.eqb z 0). - -Lemma Z_of_bool_bound : forall x, 0 <= Z_of_bool x <= 1. -Proof. - destruct x ; simpl; compute; intuition congruence. -Qed. - -Instance Inj_bool_Z : InjTyp bool Z := - { inj := Z_of_bool ; pred :=(fun x => 0 <= x <= 1) ; cstr := Z_of_bool_bound}. -Add InjTyp Inj_bool_Z. - -(** Boolean operators *) - -Instance Op_andb : BinOp andb := - { TBOp := Z.min ; - TBOpInj := ltac: (destruct n,m; reflexivity)}. -Add BinOp Op_andb. - -Instance Op_orb : BinOp orb := - { TBOp := Z.max ; - TBOpInj := ltac:(destruct n,m; reflexivity)}. -Add BinOp Op_orb. - -Instance Op_implb : BinOp implb := - { TBOp := fun x y => Z.max (1 - x) y; - TBOpInj := ltac:(destruct n,m; reflexivity) }. -Add BinOp Op_implb. - -Instance Op_xorb : BinOp xorb := - { TBOp := fun x y => Z.max (x - y) (y - x); - TBOpInj := ltac:(destruct n,m; reflexivity) }. -Add BinOp Op_xorb. - -Instance Op_negb : UnOp negb := - { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}. -Add UnOp Op_negb. - -Instance Op_eq_bool : BinRel (@eq bool) := - {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. -Add BinRel Op_eq_bool. - -Instance Op_true : CstOp true := - { TCst := 1 ; TCstInj := eq_refl }. -Add CstOp Op_true. - -Instance Op_false : CstOp false := - { TCst := 0 ; TCstInj := eq_refl }. -Add CstOp Op_false. - -(** Comparisons are encoded using the predicates [isZero] and [isLeZero].*) - -Definition isZero (z : Z) := Z_of_bool (Z.eqb z 0). - -Definition isLeZero (x : Z) := Z_of_bool (Z.leb x 0). - -Instance Op_isZero : UnOp isZero := - { TUOp := isZero; TUOpInj := ltac: (reflexivity) }. -Add UnOp Op_isZero. - -Instance Op_isLeZero : UnOp isLeZero := - { TUOp := isLeZero; TUOpInj := ltac: (reflexivity) }. -Add UnOp Op_isLeZero. - -(* Some intermediate lemma *) - -Lemma Z_eqb_isZero : forall n m, - Z_of_bool (n =? m) = isZero (n - m). -Proof. - intros ; unfold isZero. - destruct ( n =? m) eqn:EQ. - - simpl. rewrite Z.eqb_eq in EQ. - rewrite EQ. rewrite Z.sub_diag. - reflexivity. - - - destruct (n - m =? 0) eqn:EQ'. - rewrite Z.eqb_neq in EQ. - rewrite Z.eqb_eq in EQ'. - apply Zminus_eq in EQ'. - congruence. - reflexivity. -Qed. - -Lemma Z_leb_sub : forall x y, x <=? y = ((x - y) <=? 0). -Proof. - intros. - destruct (x <=?y) eqn:B1 ; - destruct (x - y <=?0) eqn:B2 ; auto. - - rewrite Z.leb_le in B1. - rewrite Z.leb_nle in B2. - rewrite Z.le_sub_0 in B2. tauto. - - rewrite Z.leb_nle in B1. - rewrite Z.leb_le in B2. - rewrite Z.le_sub_0 in B2. tauto. -Qed. - -Lemma Z_ltb_leb : forall x y, x <? y = (x +1 <=? y). -Proof. - intros. - destruct (x <?y) eqn:B1 ; - destruct (x + 1 <=?y) eqn:B2 ; auto. - - rewrite Z.ltb_lt in B1. - rewrite Z.leb_nle in B2. - apply Zorder.Zlt_le_succ in B1. - unfold Z.succ in B1. - tauto. - - rewrite Z.ltb_nlt in B1. - rewrite Z.leb_le in B2. - apply Zorder.Zle_lt_succ in B2. - unfold Z.succ in B2. - apply Zorder.Zplus_lt_reg_r in B2. - tauto. -Qed. - - -(** Comparison over Z *) - -Instance Op_Zeqb : BinOp Z.eqb := - { TBOp := fun x y => isZero (Z.sub x y) ; TBOpInj := Z_eqb_isZero}. - -Instance Op_Zleb : BinOp Z.leb := - { TBOp := fun x y => isLeZero (x-y) ; - TBOpInj := - ltac: (intros;unfold isLeZero; - rewrite Z_leb_sub; - auto) }. -Add BinOp Op_Zleb. - -Instance Op_Zgeb : BinOp Z.geb := - { TBOp := fun x y => isLeZero (y-x) ; - TBOpInj := ltac:( - intros; - unfold isLeZero; - rewrite Z.geb_leb; - rewrite Z_leb_sub; - auto) }. -Add BinOp Op_Zgeb. - -Instance Op_Zltb : BinOp Z.ltb := - { TBOp := fun x y => isLeZero (x+1-y) ; - TBOpInj := ltac:( - intros; - unfold isLeZero; - rewrite Z_ltb_leb; - rewrite <- Z_leb_sub; - reflexivity) }. - -Instance Op_Zgtb : BinOp Z.gtb := - { TBOp := fun x y => isLeZero (y-x+1) ; - TBOpInj := ltac:( - intros; - unfold isLeZero; - rewrite Z.gtb_ltb; - rewrite Z_ltb_leb; - rewrite Z_leb_sub; - rewrite Z.add_sub_swap; - reflexivity) }. -Add BinOp Op_Zgtb. - -(** Comparison over nat *) - - -Lemma Z_of_nat_eqb_iff : forall n m, - (n =? m)%nat = (Z.of_nat n =? Z.of_nat m). -Proof. - intros. - rewrite Nat.eqb_compare. - rewrite Z.eqb_compare. - rewrite Nat2Z.inj_compare. - reflexivity. -Qed. - -Lemma Z_of_nat_leb_iff : forall n m, - (n <=? m)%nat = (Z.of_nat n <=? Z.of_nat m). -Proof. - intros. - rewrite Nat.leb_compare. - rewrite Z.leb_compare. - rewrite Nat2Z.inj_compare. - reflexivity. -Qed. - -Lemma Z_of_nat_ltb_iff : forall n m, - (n <? m)%nat = (Z.of_nat n <? Z.of_nat m). -Proof. - intros. - rewrite Nat.ltb_compare. - rewrite Z.ltb_compare. - rewrite Nat2Z.inj_compare. - reflexivity. -Qed. - -Instance Op_nat_eqb : BinOp Nat.eqb := - { TBOp := fun x y => isZero (Z.sub x y) ; - TBOpInj := ltac:( - intros; simpl; - rewrite <- Z_eqb_isZero; - f_equal; apply Z_of_nat_eqb_iff) }. -Add BinOp Op_nat_eqb. - -Instance Op_nat_leb : BinOp Nat.leb := - { TBOp := fun x y => isLeZero (x-y) ; - TBOpInj := ltac:( - intros; - rewrite Z_of_nat_leb_iff; - unfold isLeZero; - rewrite Z_leb_sub; - auto) }. -Add BinOp Op_nat_leb. - -Instance Op_nat_ltb : BinOp Nat.ltb := - { TBOp := fun x y => isLeZero (x+1-y) ; - TBOpInj := ltac:( - intros; - rewrite Z_of_nat_ltb_iff; - unfold isLeZero; - rewrite Z_ltb_leb; - rewrite <- Z_leb_sub; - reflexivity) }. -Add BinOp Op_nat_ltb. - -(** Injected boolean operators *) - -Lemma Z_eqb_ZSpec_ok : forall x, 0 <= isZero x <= 1 /\ - (x = 0 <-> isZero x = 1). -Proof. - intros. - unfold isZero. - destruct (x =? 0) eqn:EQ. - - apply Z.eqb_eq in EQ. - simpl. intuition try congruence; - compute ; congruence. - - apply Z.eqb_neq in EQ. - simpl. intuition try congruence; - compute ; congruence. -Qed. - - -Instance Z_eqb_ZSpec : UnOpSpec isZero := - {| UPred := fun n r => 0 <= r <= 1 /\ (n = 0 <-> isZero n = 1) ; USpec := Z_eqb_ZSpec_ok |}. -Add Spec Z_eqb_ZSpec. - -Lemma leZeroSpec_ok : forall x, x <= 0 /\ isLeZero x = 1 \/ x > 0 /\ isLeZero x = 0. -Proof. - intros. - unfold isLeZero. - destruct (x <=? 0) eqn:EQ. - - apply Z.leb_le in EQ. - simpl. intuition congruence. - - simpl. - apply Z.leb_nle in EQ. - apply Zorder.Znot_le_gt in EQ. - tauto. -Qed. - -Instance leZeroSpec : UnOpSpec isLeZero := - {| UPred := fun n r => (n<=0 /\ r = 1) \/ (n > 0 /\ r = 0) ; USpec := leZeroSpec_ok|}. -Add Spec leZeroSpec. diff --git a/plugins/micromega/ZifyClasses.v b/plugins/micromega/ZifyClasses.v deleted file mode 100644 index d3f7f91074..0000000000 --- a/plugins/micromega/ZifyClasses.v +++ /dev/null @@ -1,232 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -Set Primitive Projections. - -(** An alternative to [zify] in ML parametrised by user-provided classes instances. - - The framework has currently several limitations that are in place for simplicity. - For instance, we only consider binary operators of type [Op: S -> S -> S]. - Another limitation is that our injection theorems e.g. [TBOpInj], - are using Leibniz equality; the payoff is that there is no need for morphisms... - *) - -(** An injection [InjTyp S T] declares an injection - from source type S to target type T. -*) -Class InjTyp (S : Type) (T : Type) := - mkinj { - (* [inj] is the injection function *) - inj : S -> T; - pred : T -> Prop; - (* [cstr] states that [pred] holds for any injected element. - [cstr (inj x)] is introduced in the goal for any leaf - term of the form [inj x] - *) - cstr : forall x, pred (inj x) - }. - -(** [BinOp Op] declares a source operator [Op: S1 -> S2 -> S3]. - *) -Class BinOp {S1 S2 S3:Type} {T:Type} (Op : S1 -> S2 -> S3) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} := - mkbop { - (* [TBOp] is the target operator after injection of operands. *) - TBOp : T -> T -> T; - (* [TBOpInj] states the correctness of the injection. *) - TBOpInj : forall (n:S1) (m:S2), inj (Op n m) = TBOp (inj n) (inj m) - }. - -(** [Unop Op] declares a source operator [Op : S1 -> S2]. *) -Class UnOp {S1 S2 T:Type} (Op : S1 -> S2) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} := - mkuop { - (* [TUOp] is the target operator after injection of operands. *) - TUOp : T -> T; - (* [TUOpInj] states the correctness of the injection. *) - TUOpInj : forall (x:S1), inj (Op x) = TUOp (inj x) - }. - -(** [CstOp Op] declares a source constant [Op : S]. *) -Class CstOp {S T:Type} (Op : S) {I : InjTyp S T} := - mkcst { - (* [TCst] is the target constant. *) - TCst : T; - (* [TCstInj] states the correctness of the injection. *) - TCstInj : inj Op = TCst - }. - -(** In the framework, [Prop] is mapped to [Prop] and the injection is phrased in - terms of [=] instead of [<->]. -*) - -(** [BinRel R] declares the injection of a binary relation. *) -Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T} := - mkbrel { - TR : T -> T -> Prop; - TRInj : forall n m : S, R n m <-> TR (@inj _ _ I n) (inj m) - }. - -(** [PropOp Op] declares morphisms for [<->]. - This will be used to deal with e.g. [and], [or],... *) -Class PropOp (Op : Prop -> Prop -> Prop) := - mkprop { - op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2) - }. - -Class PropUOp (Op : Prop -> Prop) := - mkuprop { - uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) - }. - - - -(** Once the term is injected, terms can be replaced by their specification. - NB1: The Ltac code is currently limited to (Op: Z -> Z -> Z) - NB2: This is not sufficient to cope with [Z.div] or [Z.mod] - *) -Class BinOpSpec {S T: Type} (Op : T -> T -> T) {I : InjTyp S T} := - mkbspec { - BPred : T -> T -> T -> Prop; - BSpec : forall x y, BPred x y (Op x y) - }. - -Class UnOpSpec {S T: Type} (Op : T -> T) {I : InjTyp S T} := - mkuspec { - UPred : T -> T -> Prop; - USpec : forall x, UPred x (Op x) - }. - -(** After injections, e.g. nat -> Z, - the fact that Z.of_nat x * Z.of_nat y is positive is lost. - This information can be recovered using instance of the [Saturate] class. -*) -Class Saturate {T: Type} (Op : T -> T -> T) := - mksat { - (** Given [Op x y], - - [PArg1] is the pre-condition of x - - [PArg2] is the pre-condition of y - - [PRes] is the pos-condition of (Op x y) *) - PArg1 : T -> Prop; - PArg2 : T -> Prop; - PRes : T -> Prop; - (** [SatOk] states the correctness of the reasoning *) - SatOk : forall x y, PArg1 x -> PArg2 y -> PRes (Op x y) - }. -(* The [ZifyInst.saturate] iterates over all the instances - and for every pattern of the form - [H1 : PArg1 ?x , H2 : PArg2 ?y , T : context[Op ?x ?y] |- _ ] - [H1 : PArg1 ?x , H2 : PArg2 ?y |- context[Op ?x ?y] ] - asserts (SatOK x y H1 H2) *) - -(** The rest of the file is for internal use by the ML tactic. - There are data-structures and lemmas used to inductively construct - the injected terms. *) - -(** The data-structures [injterm] and [injected_prop] - are used to store source and target expressions together - with a correctness proof. *) - -Record injterm {S T: Type} {I : S -> T} := - mkinjterm { source : S ; target : T ; inj_ok : I source = target}. - -Record injprop := - mkinjprop { - source_prop : Prop ; target_prop : Prop ; - injprop_ok : source_prop <-> target_prop}. - -(** Lemmas for building [injterm] and [injprop]. *) - -Definition mkprop_op (Op : Prop -> Prop -> Prop) (POp : PropOp Op) - (p1 :injprop) (p2: injprop) : injprop := - {| source_prop := (Op (source_prop p1) (source_prop p2)) ; - target_prop := (Op (target_prop p1) (target_prop p2)) ; - injprop_ok := (op_iff (source_prop p1) (source_prop p2) (target_prop p1) (target_prop p2) - (injprop_ok p1) (injprop_ok p2)) - |}. - - -Definition mkuprop_op (Op : Prop -> Prop) (POp : PropUOp Op) - (p1 :injprop) : injprop := - {| source_prop := (Op (source_prop p1)) ; - target_prop := (Op (target_prop p1)) ; - injprop_ok := (uop_iff (source_prop p1) (target_prop p1) (injprop_ok p1)) - |}. - - -Lemma mkapp2 (S1 S2 S3 T : Type) (Op : S1 -> S2 -> S3) - {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} - (B : @BinOp S1 S2 S3 T Op I1 I2 I3) - (t1 : @injterm S1 T inj) (t2 : @injterm S2 T inj) - : @injterm S3 T inj. -Proof. - apply (mkinjterm _ _ inj (Op (source t1) (source t2)) (TBOp (target t1) (target t2))). - (rewrite <- inj_ok; - rewrite <- inj_ok; - apply TBOpInj). -Defined. - -Lemma mkapp (S1 S2 T : Type) (Op : S1 -> S2) - {I1 : InjTyp S1 T} - {I2 : InjTyp S2 T} - (B : @UnOp S1 S2 T Op I1 I2 ) - (t1 : @injterm S1 T inj) - : @injterm S2 T inj. -Proof. - apply (mkinjterm _ _ inj (Op (source t1)) (TUOp (target t1))). - (rewrite <- inj_ok; apply TUOpInj). -Defined. - -Lemma mkapp0 (S T : Type) (Op : S) - {I : InjTyp S T} - (B : @CstOp S T Op I) - : @injterm S T inj. -Proof. - apply (mkinjterm _ _ inj Op TCst). - (apply TCstInj). -Defined. - -Lemma mkrel (S T : Type) (R : S -> S -> Prop) - {Inj : InjTyp S T} - (B : @BinRel S T R Inj) - (t1 : @injterm S T inj) (t2 : @injterm S T inj) - : @injprop. -Proof. - apply (mkinjprop (R (source t1) (source t2)) (TR (target t1) (target t2))). - (rewrite <- inj_ok; rewrite <- inj_ok;apply TRInj). -Defined. - -(** Registering constants for use by the plugin *) -Register target_prop as ZifyClasses.target_prop. -Register mkrel as ZifyClasses.mkrel. -Register target as ZifyClasses.target. -Register mkapp2 as ZifyClasses.mkapp2. -Register mkapp as ZifyClasses.mkapp. -Register mkapp0 as ZifyClasses.mkapp0. -Register op_iff as ZifyClasses.op_iff. -Register uop_iff as ZifyClasses.uop_iff. -Register TR as ZifyClasses.TR. -Register TBOp as ZifyClasses.TBOp. -Register TUOp as ZifyClasses.TUOp. -Register TCst as ZifyClasses.TCst. -Register mkprop_op as ZifyClasses.mkprop_op. -Register mkuprop_op as ZifyClasses.mkuprop_op. -Register injprop_ok as ZifyClasses.injprop_ok. -Register inj_ok as ZifyClasses.inj_ok. -Register source as ZifyClasses.source. -Register source_prop as ZifyClasses.source_prop. -Register inj as ZifyClasses.inj. -Register TRInj as ZifyClasses.TRInj. -Register TUOpInj as ZifyClasses.TUOpInj. -Register not as ZifyClasses.not. -Register mkinjterm as ZifyClasses.mkinjterm. -Register eq_refl as ZifyClasses.eq_refl. -Register mkinjprop as ZifyClasses.mkinjprop. -Register iff_refl as ZifyClasses.iff_refl. -Register source_prop as ZifyClasses.source_prop. -Register injprop_ok as ZifyClasses.injprop_ok. -Register iff as ZifyClasses.iff. diff --git a/plugins/micromega/ZifyComparison.v b/plugins/micromega/ZifyComparison.v deleted file mode 100644 index df75cf2c05..0000000000 --- a/plugins/micromega/ZifyComparison.v +++ /dev/null @@ -1,82 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Bool ZArith. -Require Import Zify ZifyClasses. -Require Import Lia. -Local Open Scope Z_scope. - -(** [Z_of_comparison] is the injection function for comparison *) -Definition Z_of_comparison (c : comparison) : Z := - match c with - | Lt => -1 - | Eq => 0 - | Gt => 1 - end. - -Lemma Z_of_comparison_bound : forall x, -1 <= Z_of_comparison x <= 1. -Proof. - destruct x ; simpl; compute; intuition congruence. -Qed. - -Instance Inj_comparison_Z : InjTyp comparison Z := - { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}. -Add InjTyp Inj_comparison_Z. - -Definition ZcompareZ (x y : Z) := - Z_of_comparison (Z.compare x y). - -Program Instance BinOp_Zcompare : BinOp Z.compare := - { TBOp := ZcompareZ }. -Add BinOp BinOp_Zcompare. - -Instance Op_eq_comparison : BinRel (@eq comparison) := - {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. -Add BinRel Op_eq_comparison. - -Instance Op_Eq : CstOp Eq := - { TCst := 0 ; TCstInj := eq_refl }. -Add CstOp Op_Eq. - -Instance Op_Lt : CstOp Lt := - { TCst := -1 ; TCstInj := eq_refl }. -Add CstOp Op_Lt. - -Instance Op_Gt : CstOp Gt := - { TCst := 1 ; TCstInj := eq_refl }. -Add CstOp Op_Gt. - - -Lemma Zcompare_spec : forall x y, - (x = y -> ZcompareZ x y = 0) - /\ - (x > y -> ZcompareZ x y = 1) - /\ - (x < y -> ZcompareZ x y = -1). -Proof. - unfold ZcompareZ. - intros. - destruct (x ?= y) eqn:C; simpl. - - rewrite Z.compare_eq_iff in C. - lia. - - rewrite Z.compare_lt_iff in C. - lia. - - rewrite Z.compare_gt_iff in C. - lia. -Qed. - -Instance ZcompareSpec : BinOpSpec ZcompareZ := - {| BPred := fun x y r => (x = y -> r = 0) - /\ - (x > y -> r = 1) - /\ - (x < y -> r = -1) - ; BSpec := Zcompare_spec|}. -Add Spec ZcompareSpec. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v deleted file mode 100644 index edfb5a2a94..0000000000 --- a/plugins/micromega/ZifyInst.v +++ /dev/null @@ -1,544 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Instances of [ZifyClasses] for emulating the existing zify. - Each instance is registered using a Add 'class' 'name_of_instance'. - *) - -Require Import Arith Max Min BinInt BinNat Znat Nnat. -Require Import ZifyClasses. -Declare ML Module "zify_plugin". -Local Open Scope Z_scope. - -(** Propositional logic *) -Instance PropAnd : PropOp and. -Proof. - constructor. - tauto. -Defined. -Add PropOp PropAnd. - -Instance PropOr : PropOp or. -Proof. - constructor. - tauto. -Defined. -Add PropOp PropOr. - -Instance PropArrow : PropOp (fun x y => x -> y). -Proof. - constructor. - intros. - tauto. -Defined. -Add PropOp PropArrow. - -Instance PropIff : PropOp iff. -Proof. - constructor. - intros. - tauto. -Defined. -Add PropOp PropIff. - -Instance PropNot : PropUOp not. -Proof. - constructor. - intros. - tauto. -Defined. -Add PropUOp PropNot. - - -Instance Inj_Z_Z : InjTyp Z Z := - mkinj _ _ (fun x => x) (fun x => True ) (fun _ => I). -Add InjTyp Inj_Z_Z. - -(** Support for nat *) - -Instance Inj_nat_Z : InjTyp nat Z := - mkinj _ _ Z.of_nat (fun x => 0 <= x ) Nat2Z.is_nonneg. -Add InjTyp Inj_nat_Z. - -(* zify_nat_rel *) -Instance Op_ge : BinRel ge := - {| TR := Z.ge; TRInj := Nat2Z.inj_ge |}. -Add BinRel Op_ge. - -Instance Op_lt : BinRel lt := - {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}. -Add BinRel Op_lt. - -Instance Op_gt : BinRel gt := - {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}. -Add BinRel Op_gt. - -Instance Op_le : BinRel le := - {| TR := Z.le; TRInj := Nat2Z.inj_le |}. -Add BinRel Op_le. - -Instance Op_eq_nat : BinRel (@eq nat) := - {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}. -Add BinRel Op_eq_nat. - -(* zify_nat_op *) -Instance Op_plus : BinOp Nat.add := - {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}. -Add BinOp Op_plus. - -Instance Op_sub : BinOp Nat.sub := - {| TBOp := fun n m => Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max |}. -Add BinOp Op_sub. - -Instance Op_mul : BinOp Nat.mul := - {| TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul |}. -Add BinOp Op_mul. - -Instance Op_min : BinOp Nat.min := - {| TBOp := Z.min ; TBOpInj := Nat2Z.inj_min |}. -Add BinOp Op_min. - -Instance Op_max : BinOp Nat.max := - {| TBOp := Z.max ; TBOpInj := Nat2Z.inj_max |}. -Add BinOp Op_max. - -Instance Op_pred : UnOp Nat.pred := - {| TUOp := fun n => Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max |}. -Add UnOp Op_pred. - -Instance Op_S : UnOp S := - {| TUOp := fun x => Z.add x 1 ; TUOpInj := Nat2Z.inj_succ |}. -Add UnOp Op_S. - -Instance Op_O : CstOp O := - {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}. -Add CstOp Op_O. - -Instance Op_Z_abs_nat : UnOp Z.abs_nat := - { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. -Add UnOp Op_Z_abs_nat. - -(** Support for positive *) - -Instance Inj_pos_Z : InjTyp positive Z := - {| inj := Zpos ; pred := (fun x => 0 < x ) ; cstr := Pos2Z.pos_is_pos |}. -Add InjTyp Inj_pos_Z. - -Instance Op_pos_to_nat : UnOp Pos.to_nat := - {TUOp := (fun x => x); TUOpInj := positive_nat_Z}. -Add UnOp Op_pos_to_nat. - -Instance Inj_N_Z : InjTyp N Z := - mkinj _ _ Z.of_N (fun x => 0 <= x ) N2Z.is_nonneg. -Add InjTyp Inj_N_Z. - - -Instance Op_N_to_nat : UnOp N.to_nat := - { TUOp := fun x => x ; TUOpInj := N_nat_Z }. -Add UnOp Op_N_to_nat. - -(* zify_positive_rel *) - -Instance Op_pos_ge : BinRel Pos.ge := - {| TR := Z.ge; TRInj := fun x y => iff_refl (Z.pos x >= Z.pos y) |}. -Add BinRel Op_pos_ge. - -Instance Op_pos_lt : BinRel Pos.lt := - {| TR := Z.lt; TRInj := fun x y => iff_refl (Z.pos x < Z.pos y) |}. -Add BinRel Op_pos_lt. - -Instance Op_pos_gt : BinRel Pos.gt := - {| TR := Z.gt; TRInj := fun x y => iff_refl (Z.pos x > Z.pos y) |}. -Add BinRel Op_pos_gt. - -Instance Op_pos_le : BinRel Pos.le := - {| TR := Z.le; TRInj := fun x y => iff_refl (Z.pos x <= Z.pos y) |}. -Add BinRel Op_pos_le. - -Instance Op_eq_pos : BinRel (@eq positive) := - {| TR := @eq Z ; TRInj := fun x y => iff_sym (Pos2Z.inj_iff x y) |}. -Add BinRel Op_eq_pos. - -(* zify_positive_op *) - - -Instance Op_Z_of_N : UnOp Z.of_N := - { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }. -Add UnOp Op_Z_of_N. - -Instance Op_Z_to_N : UnOp Z.to_N := - { TUOp := fun x => Z.max 0 x ; TUOpInj := ltac:(now intro x; destruct x) }. -Add UnOp Op_Z_to_N. - -Instance Op_Z_neg : UnOp Z.neg := - { TUOp := Z.opp ; TUOpInj := (fun x => eq_refl (Zneg x))}. -Add UnOp Op_Z_neg. - -Instance Op_Z_pos : UnOp Z.pos := - { TUOp := (fun x => x) ; TUOpInj := (fun x => eq_refl (Z.pos x))}. -Add UnOp Op_Z_pos. - -Instance Op_pos_succ : UnOp Pos.succ := - { TUOp := fun x => x + 1; TUOpInj := Pos2Z.inj_succ }. -Add UnOp Op_pos_succ. - -Instance Op_pos_pred_double : UnOp Pos.pred_double := - { TUOp := fun x => 2 * x - 1; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_pos_pred_double. - -Instance Op_pos_pred : UnOp Pos.pred := - { TUOp := fun x => Z.max 1 (x - 1) ; - TUOpInj := ltac : - (intros; - rewrite <- Pos.sub_1_r; - apply Pos2Z.inj_sub_max) }. -Add UnOp Op_pos_pred. - -Instance Op_pos_predN : UnOp Pos.pred_N := - { TUOp := fun x => x - 1 ; - TUOpInj := ltac: (now destruct x; rewrite N.pos_pred_spec) }. -Add UnOp Op_pos_predN. - -Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := - { TUOp := fun x => x + 1 ; TUOpInj := Zpos_P_of_succ_nat }. -Add UnOp Op_pos_of_succ_nat. - -Instance Op_pos_of_nat : UnOp Pos.of_nat := - { TUOp := fun x => Z.max 1 x ; - TUOpInj := ltac: (now destruct x; - [|rewrite <- Pos.of_nat_succ, <- (Nat2Z.inj_max 1)]) }. -Add UnOp Op_pos_of_nat. - -Instance Op_pos_add : BinOp Pos.add := - { TBOp := Z.add ; TBOpInj := ltac: (reflexivity) }. -Add BinOp Op_pos_add. - -Instance Op_pos_add_carry : BinOp Pos.add_carry := - { TBOp := fun x y => x + y + 1 ; - TBOpInj := ltac:(now intros; rewrite Pos.add_carry_spec, Pos2Z.inj_succ) }. -Add BinOp Op_pos_add_carry. - -Instance Op_pos_sub : BinOp Pos.sub := - { TBOp := fun n m => Z.max 1 (n - m) ;TBOpInj := Pos2Z.inj_sub_max }. -Add BinOp Op_pos_sub. - -Instance Op_pos_mul : BinOp Pos.mul := - { TBOp := Z.mul ; TBOpInj := ltac: (reflexivity) }. -Add BinOp Op_pos_mul. - -Instance Op_pos_min : BinOp Pos.min := - { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }. -Add BinOp Op_pos_min. - -Instance Op_pos_max : BinOp Pos.max := - { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }. -Add BinOp Op_pos_max. - -Instance Op_pos_pow : BinOp Pos.pow := - { TBOp := Z.pow ; TBOpInj := Pos2Z.inj_pow }. -Add BinOp Op_pos_pow. - -Instance Op_pos_square : UnOp Pos.square := - { TUOp := Z.square ; TUOpInj := Pos2Z.inj_square }. -Add UnOp Op_pos_square. - -Instance Op_xO : UnOp xO := - { TUOp := fun x => 2 * x ; TUOpInj := ltac: (reflexivity) }. -Add UnOp Op_xO. - -Instance Op_xI : UnOp xI := - { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (reflexivity) }. -Add UnOp Op_xI. - -Instance Op_xH : CstOp xH := - { TCst := 1%Z ; TCstInj := ltac:(reflexivity)}. -Add CstOp Op_xH. - -Instance Op_Z_of_nat : UnOp Z.of_nat:= - { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_of_nat. - -(* zify_N_rel *) -Instance Op_N_ge : BinRel N.ge := - {| TR := Z.ge ; TRInj := N2Z.inj_ge |}. -Add BinRel Op_N_ge. - -Instance Op_N_lt : BinRel N.lt := - {| TR := Z.lt ; TRInj := N2Z.inj_lt |}. -Add BinRel Op_N_lt. - -Instance Op_N_gt : BinRel N.gt := - {| TR := Z.gt ; TRInj := N2Z.inj_gt |}. -Add BinRel Op_N_gt. - -Instance Op_N_le : BinRel N.le := - {| TR := Z.le ; TRInj := N2Z.inj_le |}. -Add BinRel Op_N_le. - -Instance Op_eq_N : BinRel (@eq N) := - {| TR := @eq Z ; TRInj := fun x y : N => iff_sym (N2Z.inj_iff x y) |}. -Add BinRel Op_eq_N. - -(* zify_N_op *) -Instance Op_N_of_nat : UnOp N.of_nat := - { TUOp := fun x => x ; TUOpInj := nat_N_Z }. -Add UnOp Op_N_of_nat. - -Instance Op_Z_abs_N : UnOp Z.abs_N := - { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }. -Add UnOp Op_Z_abs_N. - -Instance Op_N_pos : UnOp N.pos := - { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity)}. -Add UnOp Op_N_pos. - -Instance Op_N_add : BinOp N.add := - {| TBOp := Z.add ; TBOpInj := N2Z.inj_add |}. -Add BinOp Op_N_add. - -Instance Op_N_min : BinOp N.min := - {| TBOp := Z.min ; TBOpInj := N2Z.inj_min |}. -Add BinOp Op_N_min. - -Instance Op_N_max : BinOp N.max := - {| TBOp := Z.max ; TBOpInj := N2Z.inj_max |}. -Add BinOp Op_N_max. - -Instance Op_N_mul : BinOp N.mul := - {| TBOp := Z.mul ; TBOpInj := N2Z.inj_mul |}. -Add BinOp Op_N_mul. - -Instance Op_N_sub : BinOp N.sub := - {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}. -Add BinOp Op_N_sub. - -Instance Op_N_div : BinOp N.div := - {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}. -Add BinOp Op_N_div. - -Instance Op_N_mod : BinOp N.modulo := - {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}. -Add BinOp Op_N_mod. - -Instance Op_N_pred : UnOp N.pred := - { TUOp := fun x => Z.max 0 (x - 1) ; - TUOpInj := - ltac:(intros; rewrite N.pred_sub; apply N2Z.inj_sub_max) }. -Add UnOp Op_N_pred. - -Instance Op_N_succ : UnOp N.succ := - {| TUOp := fun x => x + 1 ; TUOpInj := N2Z.inj_succ |}. -Add UnOp Op_N_succ. - -(** Support for Z - injected to itself *) - -(* zify_Z_rel *) -Instance Op_Z_ge : BinRel Z.ge := - {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y)|}. -Add BinRel Op_Z_ge. - -Instance Op_Z_lt : BinRel Z.lt := - {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y)|}. -Add BinRel Op_Z_lt. - -Instance Op_Z_gt : BinRel Z.gt := - {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y)|}. -Add BinRel Op_Z_gt. - -Instance Op_Z_le : BinRel Z.le := - {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y)|}. -Add BinRel Op_Z_le. - -Instance Op_eqZ : BinRel (@eq Z) := - { TR := @eq Z ; TRInj := fun x y => iff_refl (x = y) }. -Add BinRel Op_eqZ. - -Instance Op_Z_add : BinOp Z.add := - { TBOp := Z.add ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_add. - -Instance Op_Z_min : BinOp Z.min := - { TBOp := Z.min ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_min. - -Instance Op_Z_max : BinOp Z.max := - { TBOp := Z.max ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_max. - -Instance Op_Z_mul : BinOp Z.mul := - { TBOp := Z.mul ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_mul. - -Instance Op_Z_sub : BinOp Z.sub := - { TBOp := Z.sub ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_sub. - -Instance Op_Z_div : BinOp Z.div := - { TBOp := Z.div ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_div. - -Instance Op_Z_mod : BinOp Z.modulo := - { TBOp := Z.modulo ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_mod. - -Instance Op_Z_rem : BinOp Z.rem := - { TBOp := Z.rem ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_rem. - -Instance Op_Z_quot : BinOp Z.quot := - { TBOp := Z.quot ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_quot. - -Instance Op_Z_succ : UnOp Z.succ := - { TUOp := fun x => x + 1 ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_succ. - -Instance Op_Z_pred : UnOp Z.pred := - { TUOp := fun x => x - 1 ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_pred. - -Instance Op_Z_opp : UnOp Z.opp := - { TUOp := Z.opp ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_opp. - -Instance Op_Z_abs : UnOp Z.abs := - { TUOp := Z.abs ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_abs. - -Instance Op_Z_sgn : UnOp Z.sgn := - { TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }. -Add UnOp Op_Z_sgn. - -Instance Op_Z_pow : BinOp Z.pow := - { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_pow. - -Instance Op_Z_pow_pos : BinOp Z.pow_pos := - { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. -Add BinOp Op_Z_pow_pos. - -Instance Op_Z_double : UnOp Z.double := - { TUOp := Z.mul 2 ; TUOpInj := Z.double_spec }. -Add UnOp Op_Z_double. - -Instance Op_Z_pred_double : UnOp Z.pred_double := - { TUOp := fun x => 2 * x - 1 ; TUOpInj := Z.pred_double_spec }. -Add UnOp Op_Z_pred_double. - -Instance Op_Z_succ_double : UnOp Z.succ_double := - { TUOp := fun x => 2 * x + 1 ; TUOpInj := Z.succ_double_spec }. -Add UnOp Op_Z_succ_double. - -Instance Op_Z_square : UnOp Z.square := - { TUOp := fun x => x * x ; TUOpInj := Z.square_spec }. -Add UnOp Op_Z_square. - -Instance Op_Z_div2 : UnOp Z.div2 := - { TUOp := fun x => x / 2 ; TUOpInj := Z.div2_div }. -Add UnOp Op_Z_div2. - -Instance Op_Z_quot2 : UnOp Z.quot2 := - { TUOp := fun x => Z.quot x 2 ; TUOpInj := Zeven.Zquot2_quot }. -Add UnOp Op_Z_quot2. - -Lemma of_nat_to_nat_eq : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x. -Proof. - destruct x. - - reflexivity. - - rewrite Z2Nat.id. - reflexivity. - compute. congruence. - - reflexivity. -Qed. - -Instance Op_Z_to_nat : UnOp Z.to_nat := - { TUOp := fun x => Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }. -Add UnOp Op_Z_to_nat. - -(** Specification of derived operators over Z *) - -Lemma z_max_spec : forall n m, - n <= Z.max n m /\ m <= Z.max n m /\ (Z.max n m = n \/ Z.max n m = m). -Proof. - intros. - generalize (Z.le_max_l n m). - generalize (Z.le_max_r n m). - generalize (Z.max_spec_le n m). - intuition idtac. -Qed. - -Instance ZmaxSpec : BinOpSpec Z.max := - {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. -Add Spec ZmaxSpec. - -Lemma z_min_spec : forall n m, - Z.min n m <= n /\ Z.min n m <= m /\ (Z.min n m = n \/ Z.min n m = m). -Proof. - intros. - generalize (Z.le_min_l n m). - generalize (Z.le_min_r n m). - generalize (Z.min_spec_le n m). - intuition idtac. -Qed. - - -Instance ZminSpec : BinOpSpec Z.min := - {| BPred := fun n m r => n < m /\ r = n \/ m <= n /\ r = m ; - BSpec := Z.min_spec |}. -Add Spec ZminSpec. - -Instance ZsgnSpec : UnOpSpec Z.sgn := - {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ; - USpec := Z.sgn_spec|}. -Add Spec ZsgnSpec. - -Instance ZabsSpec : UnOpSpec Z.abs := - {| UPred := fun n r: Z => 0 <= n /\ r = n \/ n < 0 /\ r = - n ; - USpec := Z.abs_spec|}. -Add Spec ZabsSpec. - -(** Saturate positivity constraints *) - -Instance SatProd : Saturate Z.mul := - {| - PArg1 := fun x => 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun r => 0 <= r; - SatOk := Z.mul_nonneg_nonneg - |}. -Add Saturate SatProd. - -Instance SatProdPos : Saturate Z.mul := - {| - PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; - PRes := fun r => 0 < r; - SatOk := Z.mul_pos_pos - |}. -Add Saturate SatProdPos. - -Lemma pow_pos_strict : - forall a b, - 0 < a -> 0 < b -> 0 < a ^ b. -Proof. - intros. - apply Z.pow_pos_nonneg; auto. - apply Z.lt_le_incl;auto. -Qed. - - -Instance SatPowPos : Saturate Z.pow := - {| - PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; - PRes := fun r => 0 < r; - SatOk := pow_pos_strict - |}. -Add Saturate SatPowPos. diff --git a/plugins/micromega/Ztac.v b/plugins/micromega/Ztac.v deleted file mode 100644 index 091f58a0ef..0000000000 --- a/plugins/micromega/Ztac.v +++ /dev/null @@ -1,140 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Tactics for doing arithmetic proofs. - Useful to bootstrap lia. - *) - -Require Import ZArithRing. -Require Import ZArith_base. -Local Open Scope Z_scope. - -Lemma eq_incl : - forall (x y:Z), x = y -> x <= y /\ y <= x. -Proof. - intros; split; - apply Z.eq_le_incl; auto. -Qed. - -Lemma elim_concl_eq : - forall x y, (x < y \/ y < x -> False) -> x = y. -Proof. - intros. - destruct (Z_lt_le_dec x y). - exfalso. apply H ; auto. - destruct (Zle_lt_or_eq y x);auto. - exfalso. - apply H ; auto. -Qed. - -Lemma elim_concl_le : - forall x y, (y < x -> False) -> x <= y. -Proof. - intros. - destruct (Z_lt_le_dec y x). - exfalso ; auto. - auto. -Qed. - -Lemma elim_concl_lt : - forall x y, (y <= x -> False) -> x < y. -Proof. - intros. - destruct (Z_lt_le_dec x y). - auto. - exfalso ; auto. -Qed. - - - -Lemma Zlt_le_add_1 : forall n m : Z, n < m -> n + 1 <= m. -Proof. exact (Zlt_le_succ). Qed. - - -Ltac normZ := - repeat - match goal with - | H : _ < _ |- _ => apply Zlt_le_add_1 in H - | H : ?Y <= _ |- _ => - lazymatch Y with - | 0 => fail - | _ => apply Zle_minus_le_0 in H - end - | H : _ >= _ |- _ => apply Z.ge_le in H - | H : _ > _ |- _ => apply Z.gt_lt in H - | H : _ = _ |- _ => apply eq_incl in H ; destruct H - | |- @eq Z _ _ => apply elim_concl_eq ; let H := fresh "HZ" in intros [H|H] - | |- _ <= _ => apply elim_concl_le ; intros - | |- _ < _ => apply elim_concl_lt ; intros - | |- _ >= _ => apply Z.le_ge - end. - - -Inductive proof := -| Hyp (e : Z) (prf : 0 <= e) -| Add (p1 p2: proof) -| Mul (p1 p2: proof) -| Cst (c : Z) -. - -Lemma add_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1+e2. -Proof. - intros. - change 0 with (0+ 0). - apply Z.add_le_mono; auto. -Qed. - -Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2. -Proof. - intros. - change 0 with (0* e2). - apply Zmult_le_compat_r; auto. -Qed. - -Fixpoint eval_proof (p : proof) : { e : Z | 0 <= e} := - match p with - | Hyp e prf => exist _ e prf - | Add p1 p2 => let (e1,p1) := eval_proof p1 in - let (e2,p2) := eval_proof p2 in - exist _ _ (add_le _ _ p1 p2) - | Mul p1 p2 => let (e1,p1) := eval_proof p1 in - let (e2,p2) := eval_proof p2 in - exist _ _ (mul_le _ _ p1 p2) - | Cst c => match Z_le_dec 0 c with - | left prf => exist _ _ prf - | _ => exist _ _ Z.le_0_1 - end - end. - -Ltac lia_step p := - let H := fresh in - let prf := (eval cbn - [Z.le Z.mul Z.opp Z.sub Z.add] in (eval_proof p)) in - match prf with - | @exist _ _ _ ?P => pose proof P as H - end ; ring_simplify in H. - -Ltac lia_contr := - match goal with - | H : 0 <= - (Zpos _) |- _ => - rewrite <- Z.leb_le in H; - compute in H ; discriminate - | H : 0 <= (Zneg _) |- _ => - rewrite <- Z.leb_le in H; - compute in H ; discriminate - end. - - -Ltac lia p := - lia_step p ; lia_contr. - -Ltac slia H1 H2 := - normZ ; lia (Add (Hyp _ H1) (Hyp _ H2)). - -Arguments Hyp {_} prf. diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v deleted file mode 100644 index 896ee303cc..0000000000 --- a/plugins/nsatz/Nsatz.v +++ /dev/null @@ -1,525 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* - Tactic nsatz: proofs of polynomials equalities in an integral domain -(commutative ring without zero divisor). - -Examples: see test-suite/success/Nsatz.v - -Reification is done using type classes, defined in Ncring_tac.v - -*) - -Require Import List. -Require Import Setoid. -Require Import BinPos. -Require Import BinList. -Require Import Znumtheory. -Require Export Morphisms Setoid Bool. -Require Export Algebra_syntax. -Require Export Ncring. -Require Export Ncring_initial. -Require Export Ncring_tac. -Require Export Integral_domain. -Require Import DiscrR. -Require Import ZArith. -Require Import Lia. - -Declare ML Module "nsatz_plugin". - -Section nsatz1. - -Context {R:Type}`{Rid:Integral_domain R}. - -Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. -intros x y H; setoid_replace x with ((x - y) + y); simpl; - [setoid_rewrite H | idtac]; simpl. cring. cring. -Qed. - -Lemma psos_r1: forall x y, x == y -> x - y == 0. -intros x y H; simpl; setoid_rewrite H; simpl; cring. -Qed. - -Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). -intros. -intro; apply H. -simpl; setoid_replace x with ((x - y) + y). simpl. -setoid_rewrite H0. -simpl; cring. -simpl. simpl; cring. -Qed. - -(* adpatation du code de Benjamin aux setoides *) -Export Ring_polynom. -Export InitialRing. - -Definition PolZ := Pol Z. -Definition PEZ := PExpr Z. - -Definition P0Z : PolZ := P0 (C:=Z) 0%Z. - -Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Z.add Zeq_bool. - -Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. - -Definition PolZeq := @Peq Z Zeq_bool. - -Definition norm := - @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. - -Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := - match la, lp with - | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) - | _, _ => P0Z - end. - -Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := - match lla with - | List.nil => lp - | la::lla => compute_list lla ((mult_l la lp)::lp) - end. - -Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := - let (lla, lq) := certif in - let lp := List.map norm lpe in - PolZeq (norm qe) (mult_l lq (compute_list lla lp)). - - -(* Correction *) -Definition PhiR : list R -> PolZ -> R := - (Pphi ring0 add mul - (InitialRing.gen_phiZ ring0 ring1 add mul opp)). - -Definition PEevalR : list R -> PEZ -> R := - PEeval ring0 ring1 add mul sub opp - (gen_phiZ ring0 ring1 add mul opp) - N.to_nat pow. - -Lemma P0Z_correct : forall l, PhiR l P0Z = 0. -Proof. trivial. Qed. - -Lemma Rext: ring_eq_ext add mul opp _==_. -Proof. -constructor; solve_proper. -Qed. - -Lemma Rset : Setoid_Theory R _==_. -apply ring_setoid. -Qed. - -Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. -apply mk_rt. -apply ring_add_0_l. -apply ring_add_comm. -apply ring_add_assoc. -apply ring_mul_1_l. -apply cring_mul_comm. -apply ring_mul_assoc. -apply ring_distr_l. -apply ring_sub_def. -apply ring_opp_def. -Defined. - -Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). -Proof. -unfold PolZadd, PhiR. intros. simpl. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). -Proof. -unfold PolZmul, PhiR. intros. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma R_power_theory - : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. -apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. -reflexivity. Qed. - -Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). -Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). -Qed. - -Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> - PhiR l P == PhiR l P'. -Proof. - intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. -Qed. - -Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with - | List.nil => True - | a::l => Interp a == 0 /\ Cond0 A Interp l - end. - -Lemma mult_l_correct : forall l la lp, - Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) == 0. -Proof. - induction la;simpl;intros. cring. - destruct lp;trivial. simpl. cring. - simpl in H;destruct H. - rewrite PolZadd_correct. - simpl. rewrite PolZmul_correct. simpl. rewrite H. - rewrite IHla. cring. trivial. -Qed. - -Lemma compute_list_correct : forall l lla lp, - Cond0 PolZ (PhiR l) lp -> - Cond0 PolZ (PhiR l) (compute_list lla lp). -Proof. - induction lla;simpl;intros;trivial. - apply IHlla;simpl;split;trivial. - apply mult_l_correct;trivial. -Qed. - -Lemma check_correct : - forall l lpe qe certif, - check lpe qe certif = true -> - Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe == 0. -Proof. - unfold check;intros l lpe qe (lla, lq) H2 H1. - apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. - apply mult_l_correct. - apply compute_list_correct. - clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. - rewrite <- norm_correct;auto. -Qed. - -(* fin *) - -Definition R2:= 1 + 1. - -Fixpoint IPR p {struct p}: R := - match p with - xH => ring1 - | xO xH => 1+1 - | xO p1 => R2*(IPR p1) - | xI xH => 1+(1+1) - | xI p1 => 1+(R2*(IPR p1)) - end. - -Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) - end. - -Fixpoint interpret3 t fv {struct t}: R := - match t with - | (PEadd t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => - let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) - | (PEc t1) => (IZR1 t1) - | PEO => 0 - | PEI => 1 - | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 - end. - - -End nsatz1. - -Ltac equality_to_goal H x y:= - (* eliminate trivial hypotheses, but it takes time!: - let h := fresh "nH" in - (assert (h:equality x y); - [solve [cring] | clear H; clear h]) - || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) -. - -Ltac equalities_to_goal := - lazymatch goal with - | H: (_ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y -(* extension possible :-) *) - | H: (?x == ?y) |- _ => equality_to_goal H x y - end. - -(* lp est incluse dans fv. La met en tete. *) - -Ltac parametres_en_tete fv lp := - match fv with - | (@nil _) => lp - | (@cons _ ?x ?fv1) => - let res := AddFvTail x lp in - parametres_en_tete fv1 res - end. - -Ltac append1 a l := - match l with - | (@nil _) => constr:(cons a l) - | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') - end. - -Ltac rev l := - match l with - |(@nil _) => l - | (cons ?x ?l) => let l' := rev l in append1 x l' - end. - -Ltac nsatz_call_n info nparam p rr lp kont := -(* idtac "Trying power: " rr;*) - let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in -(* idtac "calcul...";*) - nsatz_compute ll; -(* idtac "done";*) - match goal with - | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => - intros _; - let lci := fresh "lci" in - set (lci:=lci0); - let lq := fresh "lq" in - set (lq:=lq0); - kont c rr lq lci - end. - -Ltac nsatz_call radicalmax info nparam p lp kont := - let rec try_n n := - lazymatch n with - | 0%N => fail - | _ => - (let r := eval compute in (N.sub radicalmax (N.pred n)) in - nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (N.pred n) in try_n n' - end in - try_n radicalmax. - - -Ltac lterm_goal g := - match g with - ?b1 == ?b2 => constr:(b1::b2::nil) - | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) - end. - -Ltac reify_goal l le lb:= - match le with - nil => idtac - | ?e::?le1 => - match lb with - ?b::?lb1 => (* idtac "b="; idtac b;*) - let x := fresh "B" in - set (x:= b) at 1; - change x with (interpret3 e l); - clear x; - reify_goal l le1 lb1 - end - end. - -Ltac get_lpol g := - match g with - (interpret3 ?p _) == _ => constr:(p::nil) - | (interpret3 ?p _) == _ -> ?g => - let l := get_lpol g in constr:(p::l) - end. - -Ltac nsatz_generic radicalmax info lparam lvar := - let nparam := eval compute in (Z.of_nat (List.length lparam)) in - match goal with - |- ?g => let lb := lterm_goal g in - match (match lvar with - |(@nil _) => - match lparam with - |(@nil _) => - let r := eval red in (list_reifyl (lterm:=lb)) in r - |_ => - match eval red in (list_reifyl (lterm:=lb)) with - |(?fv, ?le) => - let fv := parametres_en_tete fv lparam in - (* we reify a second time, with the good order - for variables *) - let r := eval red in - (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end - end - |_ => - let fv := parametres_en_tete lvar lparam in - let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end) with - |(?fv, ?le) => - reify_goal fv le lb ; - match goal with - |- ?g => - let lp := get_lpol g in - let lpol := eval compute in (List.rev lp) in - intros; - - let SplitPolyList kont := - match lpol with - | ?p2::?lp2 => kont p2 lp2 - | _ => idtac "polynomial not in the ideal" - end in - - SplitPolyList ltac:(fun p lp => - let p21 := fresh "p21" in - let lp21 := fresh "lp21" in - set (p21:=p) ; - set (lp21:=lp); -(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - let q := fresh "q" in - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); - [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: (interpret3 q fv) == 0); - [ (*simpl*) idtac; - generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); - let cc := fresh "H" in - (*simpl*) idtac; intro cc; apply cc; clear cc; - (*simpl*) idtac; - repeat (split;[assumption|idtac]); exact I - | (*simpl in Hg2;*) (*simpl*) idtac; - apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); - (*simpl*) idtac; - try apply integral_domain_one_zero; - try apply integral_domain_minus_one_zero; - try trivial; - try exact integral_domain_one_zero; - try exact integral_domain_minus_one_zero - || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, - one, one_notation, multiplication, mul_notation, zero, zero_notation; - discrR || lia ]) - || ((*simpl*) idtac) || idtac "could not prove discrimination result" - ] - ] -) -) -end end end . - -Ltac nsatz_default:= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic 6%N 1%Z (@nil r) (@nil r) - end. - -Tactic Notation "nsatz" := nsatz_default. - -Tactic Notation "nsatz" "with" - "radicalmax" ":=" constr(radicalmax) - "strategy" ":=" constr(info) - "parameters" ":=" constr(lparam) - "variables" ":=" constr(lvar):= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic radicalmax info lparam lvar - end. - -(* Real numbers *) -Require Import Reals. -Require Import RealField. - -Lemma Rsth : Setoid_Theory R (@eq R). -constructor;red;intros;subst;trivial. -Qed. - -Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). -Defined. - -Instance Rri : (Ring (Ro:=Rops)). -constructor; -try (try apply Rsth; - try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; - intros; try rewrite H; try rewrite H0; reflexivity)). - exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. - exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. - exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. -exact Rplus_opp_r. -Defined. - -Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. -Hint Extern 0 (can_compute_Z ?v) => - match isZcst v with true => exact I end : typeclass_instances. -Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). -Defined. - -Lemma R_one_zero: 1%R <> 0%R. -discrR. -Qed. - -Instance Rcri: (Cring (Rr:=Rri)). -red. exact Rmult_comm. Defined. - -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. -exact Rmult_integral. exact R_one_zero. Defined. - -(* Rational numbers *) -Require Import QArith. - -Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). -Defined. - -Instance Qri : (Ring (Ro:=Qops)). -constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. -apply Qopp_comp. - exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. - exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. -reflexivity. exact Qplus_opp_r. -Defined. - -Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -Proof. unfold Qeq. simpl. lia. Qed. - -Instance Qcri: (Cring (Rr:=Qri)). -red. exact Qmult_comm. Defined. - -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. -exact Qmult_integral. exact Q_one_zero. Defined. - -(* Integers *) -Lemma Z_one_zero: 1%Z <> 0%Z. -Proof. lia. Qed. - -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -exact Zmult_integral. exact Z_one_zero. Defined. - diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v deleted file mode 100644 index 4ceb530827..0000000000 --- a/plugins/omega/Omega.v +++ /dev/null @@ -1,55 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(* We import what is necessary for Omega *) -Require Export ZArith_base. -Require Export OmegaLemmas. -Require Export PreOmega. - -Declare ML Module "omega_plugin". - -Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l - Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r - Z.mul_add_distr_l: zarith. - -Require Export Zhints. - -Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. -Hint Extern 10 (_ <= _) => abstract omega: zarith. -Hint Extern 10 (_ < _) => abstract omega: zarith. -Hint Extern 10 (_ >= _) => abstract omega: zarith. -Hint Extern 10 (_ > _) => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. -Hint Extern 10 (~ _ <= _) => abstract omega: zarith. -Hint Extern 10 (~ _ < _) => abstract omega: zarith. -Hint Extern 10 (~ _ >= _) => abstract omega: zarith. -Hint Extern 10 (~ _ > _) => abstract omega: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. -Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ < _)%Z => abstract omega: zarith. -Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ > _)%Z => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. - -Hint Extern 10 False => abstract omega: zarith. diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v deleted file mode 100644 index d2378569fc..0000000000 --- a/plugins/omega/OmegaLemmas.v +++ /dev/null @@ -1,307 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import BinInt Znat. -Local Open Scope Z_scope. - -(** Factorization lemmas *) - -Theorem Zred_factor0 n : n = n * 1. -Proof. - now Z.nzsimpl. -Qed. - -Theorem Zred_factor1 n : n + n = n * 2. -Proof. - rewrite Z.mul_comm. apply Z.add_diag. -Qed. - -Theorem Zred_factor2 n m : n + n * m = n * (1 + m). -Proof. - rewrite Z.mul_add_distr_l; now Z.nzsimpl. -Qed. - -Theorem Zred_factor3 n m : n * m + n = n * (1 + m). -Proof. - now Z.nzsimpl. -Qed. - -Theorem Zred_factor4 n m p : n * m + n * p = n * (m + p). -Proof. - symmetry; apply Z.mul_add_distr_l. -Qed. - -Theorem Zred_factor5 n m : n * 0 + m = m. -Proof. - now Z.nzsimpl. -Qed. - -Theorem Zred_factor6 n : n = n + 0. -Proof. - now Z.nzsimpl. -Qed. - -(** Other specific variants of theorems dedicated for the Omega tactic *) - -Lemma new_var : forall x : Z, exists y : Z, x = y. -Proof. -intros x; now exists x. -Qed. - -Lemma OMEGA1 x y : x = y -> 0 <= x -> 0 <= y. -Proof. -now intros ->. -Qed. - -Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y. -Proof. -Z.order_pos. -Qed. - -Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0. -Proof. -intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst. -Qed. - -Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0. -Proof. -Z.swap_greater. intros Hx Hxy. -rewrite Z.add_move_0_l, <- Z.mul_opp_l. -destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]]. -- intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0). - apply Z.mul_pos_cancel_r with y; Z.order. -- Z.nzsimpl. Z.order. -- rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order. -Qed. - -Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0. -Proof. -now intros -> ->. -Qed. - -Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z. -Proof. -intros H ->. now Z.nzsimpl. -Qed. - -Lemma OMEGA7 x y z t : - z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. -Proof. -intros. Z.swap_greater. Z.order_pos. -Qed. - -Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. -Proof. -intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order. -Qed. - -Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0. -Proof. -intros. subst. now rewrite Z.add_opp_diag_l. -Qed. - -Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3. -Qed. - -Lemma OMEGA11 v1 c1 l1 l2 k1 : - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -now rewrite Z.add_assoc. -Qed. - -Lemma OMEGA12 v2 c2 l1 l2 k2 : - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). -Proof. -rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -apply Z.add_shuffle3. -Qed. - -Lemma OMEGA13 (v l1 l2 : Z) (x : positive) : - v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. -Proof. - rewrite Z.add_shuffle1. - rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. - now Z.nzsimpl. -Qed. - -Lemma OMEGA14 (v l1 l2 : Z) (x : positive) : - v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. -Proof. - rewrite Z.add_shuffle1. - rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. - now Z.nzsimpl. -Qed. - -Lemma OMEGA15 v c1 c2 l1 l2 k2 : - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). -Proof. - rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. - apply Z.add_shuffle1. -Qed. - -Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k. -Proof. - now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. -Qed. - -Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. -Proof. - unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl. -Qed. - -Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0. -Proof. - unfold Zne, not. intros. subst; auto. -Qed. - -Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. -Proof. - unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx. - destruct Hx as [LT|GT]. - - right. change (-1) with (-(1)). - rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl. - rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l. - - left. now apply Z.lt_le_pred. -Qed. - -Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. -Proof. - unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3; - simpl in H3; rewrite Z.add_0_r in H3; trivial with arith. -Qed. - -Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) - (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y). - -Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). - -Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) - (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p). - -Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) - (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p). - -Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := - eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). - -Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) - (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := - eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). -Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). - -Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). -Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) - (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). - -Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). - -Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) - (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). - -Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) - (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x). - -Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) - (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y). - -Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) - (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). - -Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). - -Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) - (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). -Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). - -Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) - (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). - -Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). - -Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). - -Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) - (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). - -Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) - (H : P y) := eq_ind_r P H (Zred_factor5 x y). - -Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) - (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). - -Theorem intro_Z : - forall n:nat, exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0. -Proof. - intros n; exists (Z.of_nat n); split; trivial. - rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. -Qed. - -Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. -Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. -Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. -Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. -Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. -Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. - -Register OMEGA1 as plugins.omega.OMEGA1. -Register OMEGA2 as plugins.omega.OMEGA2. -Register OMEGA3 as plugins.omega.OMEGA3. -Register OMEGA4 as plugins.omega.OMEGA4. -Register OMEGA5 as plugins.omega.OMEGA5. -Register OMEGA6 as plugins.omega.OMEGA6. -Register OMEGA7 as plugins.omega.OMEGA7. -Register OMEGA8 as plugins.omega.OMEGA8. -Register OMEGA9 as plugins.omega.OMEGA9. -Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. -Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. -Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. -Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. -Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. -Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. -Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. -Register OMEGA17 as plugins.omega.OMEGA17. -Register OMEGA18 as plugins.omega.OMEGA18. -Register OMEGA19 as plugins.omega.OMEGA19. -Register OMEGA20 as plugins.omega.OMEGA20. - -Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. -Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. -Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. -Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. -Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. -Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. -Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. - -Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. -Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. -Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. -Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. - -Register new_var as plugins.omega.new_var. -Register intro_Z as plugins.omega.intro_Z. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v deleted file mode 100644 index 303eb0527a..0000000000 --- a/plugins/omega/OmegaPlugin.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/plugins/omega/OmegaTactic.v b/plugins/omega/OmegaTactic.v deleted file mode 100644 index 303eb0527a..0000000000 --- a/plugins/omega/OmegaTactic.v +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v deleted file mode 100644 index 34533670f8..0000000000 --- a/plugins/omega/PreOmega.v +++ /dev/null @@ -1,588 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Arith Max Min BinInt BinNat Znat Nnat. - -Local Open Scope Z_scope. - -(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) - -(** These tactic use the complete specification of [Z.div] and - [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these - functions from the goal without losing information. The - [Z.euclidean_division_equations_cleanup] tactic removes needless - hypotheses, which makes tactics like [nia] run faster. The tactic - [Z.to_euclidean_division_equations] combines the handling of both variants - of division/quotient and modulo/remainder. *) - -Module Z. - Lemma mod_0_r_ext x y : y = 0 -> x mod y = 0. - Proof. intro; subst; destruct x; reflexivity. Qed. - Lemma div_0_r_ext x y : y = 0 -> x / y = 0. - Proof. intro; subst; destruct x; reflexivity. Qed. - - Lemma rem_0_r_ext x y : y = 0 -> Z.rem x y = x. - Proof. intro; subst; destruct x; reflexivity. Qed. - Lemma quot_0_r_ext x y : y = 0 -> Z.quot x y = 0. - Proof. intro; subst; destruct x; reflexivity. Qed. - - Lemma rem_bound_pos_pos x y : 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. - Proof. intros; apply Z.rem_bound_pos; assumption. Qed. - Lemma rem_bound_neg_pos x y : y < 0 -> 0 <= x -> 0 <= Z.rem x y < -y. - Proof. rewrite <- Z.rem_opp_r'; intros; apply Z.rem_bound_pos; rewrite ?Z.opp_pos_neg; assumption. Qed. - Lemma rem_bound_pos_neg x y : 0 < y -> x <= 0 -> -y < Z.rem x y <= 0. - Proof. rewrite <- (Z.opp_involutive x), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg; apply rem_bound_pos_pos. Qed. - Lemma rem_bound_neg_neg x y : y < 0 -> x <= 0 -> y < Z.rem x y <= 0. - Proof. rewrite <- (Z.opp_involutive x), <- (Z.opp_involutive y), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg, Z.opp_involutive; apply rem_bound_neg_pos. Qed. - - Ltac div_mod_to_equations_generalize x y := - pose proof (Z.div_mod x y); - pose proof (Z.mod_pos_bound x y); - pose proof (Z.mod_neg_bound x y); - pose proof (div_0_r_ext x y); - pose proof (mod_0_r_ext x y); - let q := fresh "q" in - let r := fresh "r" in - set (q := x / y) in *; - set (r := x mod y) in *; - clearbody q r. - Ltac quot_rem_to_equations_generalize x y := - pose proof (Z.quot_rem' x y); - pose proof (rem_bound_pos_pos x y); - pose proof (rem_bound_pos_neg x y); - pose proof (rem_bound_neg_pos x y); - pose proof (rem_bound_neg_neg x y); - pose proof (quot_0_r_ext x y); - pose proof (rem_0_r_ext x y); - let q := fresh "q" in - let r := fresh "r" in - set (q := Z.quot x y) in *; - set (r := Z.rem x y) in *; - clearbody q r. - - Ltac div_mod_to_equations_step := - match goal with - | [ |- context[?x / ?y] ] => div_mod_to_equations_generalize x y - | [ |- context[?x mod ?y] ] => div_mod_to_equations_generalize x y - | [ H : context[?x / ?y] |- _ ] => div_mod_to_equations_generalize x y - | [ H : context[?x mod ?y] |- _ ] => div_mod_to_equations_generalize x y - end. - Ltac quot_rem_to_equations_step := - match goal with - | [ |- context[Z.quot ?x ?y] ] => quot_rem_to_equations_generalize x y - | [ |- context[Z.rem ?x ?y] ] => quot_rem_to_equations_generalize x y - | [ H : context[Z.quot ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y - | [ H : context[Z.rem ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y - end. - Ltac div_mod_to_equations' := repeat div_mod_to_equations_step. - Ltac quot_rem_to_equations' := repeat quot_rem_to_equations_step. - Ltac euclidean_division_equations_cleanup := - repeat match goal with - | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl) - | [ H : ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?x < ?x -> _ |- _ ] => clear H - | [ H : ?T -> _, H' : ?T |- _ ] => specialize (H H') - | [ H : ?T -> _, H' : ~?T |- _ ] => clear H - | [ H : ~?T -> _, H' : ?T |- _ ] => clear H - | [ H : ?A -> ?x = ?x -> _ |- _ ] => specialize (fun a => H a eq_refl) - | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H - | [ H : ?A -> ?B -> _, H' : ?B |- _ ] => specialize (fun a => H a H') - | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H - | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H - | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H - | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H - | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H - | [ H : 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?A -> 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) - | [ H : ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) - | [ H : ?A -> ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) - | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H - | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H - | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H - end. - Ltac div_mod_to_equations := div_mod_to_equations'; euclidean_division_equations_cleanup. - Ltac quot_rem_to_equations := quot_rem_to_equations'; euclidean_division_equations_cleanup. - Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. -End Z. - -Set Warnings "-deprecated-tactic". - -(** * zify: the Z-ification tactic *) - -(* This tactic searches for nat and N and positive elements in the goal and - translates everything into Z. It is meant as a pre-processor for - (r)omega; for instance a positivity hypothesis is added whenever - - a multiplication is encountered - - an atom is encountered (that is a variable or an unknown construct) - - Recognized relations (can be handled as deeply as allowed by setoid rewrite): - - { eq, le, lt, ge, gt } on { Z, positive, N, nat } - - Recognized operations: - - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < = - - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat - - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat - - on N: N0 Npos + * - N.pred N.succ N.min N.max N.of_nat Z.abs_N -*) - - - - -(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - pose proof (thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop t thm a := - (* If a is a scalar, we can simply reduce the unop. *) - (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) - let isz := isZcst a in - match isz with - | true => - let u := eval compute in (t a) in - change (t a) with u in * - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_op_1 := - match goal with - | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b - | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b - | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b - | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b - | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a - | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a - | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a - | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a - end. - -Ltac zify_op := repeat zify_op_1. - - -(** II) Conversion from nat to Z *) - - -Definition Z_of_nat' := Z.of_nat. - -Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z.of_nat t) in *; - change Z.of_nat with Z_of_nat' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat_rel := - match goal with - (* I: equalities *) - | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) - | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H - | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) - (* II: less than *) - | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H - | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H - | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) - (* IV: greater than *) - | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H - | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H - | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) - end. - -Ltac zify_nat_op := - match goal with - (* misc type conversions: positive/N/Z to nat *) - | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H - | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) - | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H - | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) - | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H - | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) - - (* plus -> Z.add *) - | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H - | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) - - (* min -> Z.min *) - | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H - | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) - - (* max -> Z.max *) - | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H - | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) - - (* minus -> Z.max (Z.sub ... ...) 0 *) - | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H - | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H - | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) - - (* mult -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - | |- context [ Z.of_nat (mult ?a ?b) ] => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - - (* O -> Z0 *) - | H : context [ Z.of_nat O ] |- _ => change (Z.of_nat O) with Z0 in H - | |- context [ Z.of_nat O ] => change (Z.of_nat O) with Z0 - - (* S -> number or Z.succ *) - | H : context [ Z.of_nat (S ?a) ] |- _ => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t in H - | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in this one hypothesis *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H - end - | |- context [ Z.of_nat (S ?a) ] => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t - | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in the goal *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) - end - - (* atoms of type nat : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a - | _ : context [ Z.of_nat ?a ] |- _ => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - | |- context [ Z.of_nat ?a ] => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - -(* III) conversion from positive to Z *) - -Definition Zpos' := Zpos. -Definition Zneg' := Zneg. - -Ltac hide_Zpos t := - let z := fresh "z" in set (z:=Zpos t) in *; - change Zpos with Zpos' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_rel := - match goal with - (* I: equalities *) - | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq positive ?a ?b) => apply Pos2Z.inj - | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H - | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H - | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H - | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) - (* IV: greater than *) - | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H - | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H - | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_op := - match goal with - (* Z.pow_pos -> Z.pow *) - | H : context [ Z.pow_pos ?a ?b ] |- _ => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) in H - | |- context [ Z.pow_pos ?a ?b ] => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) - (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) in H - | _ => change (Zneg a) with (- Zpos a) in H - end - | |- context [ Zneg ?a ] => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) - | _ => change (Zneg a) with (- Zpos a) - end - - (* misc type conversions: nat to positive *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Z.power_pos *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Pos.add -> Z.add *) - | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H - | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) - - (* Pos.min -> Z.min *) - | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H - | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) - - (* Pos.max -> Z.max *) - | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H - | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) - - (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) - | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub_max a b) in H - | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub_max a b) - - (* Pos.succ -> Z.succ *) - | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H - | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) - - (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) - | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H - | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) - - (* Pos.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Zpos (?a * ?b) ] |- _ => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - | |- context [ Zpos (?a * ?b) ] => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - - (* xO *) - | H : context [ Zpos (xO ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H - | _ => rewrite (Pos2Z.inj_xO a) in H - end - | |- context [ Zpos (xO ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) - | _ => rewrite (Pos2Z.inj_xO a) - end - (* xI *) - | H : context [ Zpos (xI ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H - | _ => rewrite (Pos2Z.inj_xI a) in H - end - | |- context [ Zpos (xI ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) - | _ => rewrite (Pos2Z.inj_xI a) - end - - (* xI : nothing to do, just prevent adding a useless positivity condition *) - | H : context [ Zpos xH ] |- _ => hide_Zpos xH - | |- context [ Zpos xH ] => hide_Zpos xH - - (* atoms of type positive : we add a positivity condition (if not already there) *) - | _ : 0 < Zpos ?a |- _ => hide_Zpos a - | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a - | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive := - repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. - - - - - -(* IV) conversion from N to Z *) - -Definition Z_of_N' := Z.of_N. - -Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z.of_N t) in *; - change Z.of_N with Z_of_N' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_rel := - match goal with - (* I: equalities *) - | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) - | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H - | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H - | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H - | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) - (* IV: greater than *) - | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H - | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H - | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_op := - match goal with - (* misc type conversions: nat to positive *) - | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H - | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) - | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H - | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) - | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H - | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) - | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H - | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 - - (* N.add -> Z.add *) - | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H - | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) - - (* N.min -> Z.min *) - | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H - | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) - - (* N.max -> Z.max *) - | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H - | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) - - (* N.sub -> Z.max 0 (Z.sub ... ...) *) - | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H - | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_N (N.pred ?a) ] |- _ => rewrite (N.pred_sub a) in H - | |- context [ Z.of_N (N.pred ?a) ] => rewrite (N.pred_sub a) - - (* N.succ -> Z.succ *) - | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H - | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) - - (* N.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - | |- context [ Z.of_N (N.mul ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - - (* N.div -> Z.div and a positivity hypothesis *) - | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - - (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) - | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - - (* atoms of type N : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a - | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. - -(** The complete Z-ification tactic *) - -Require Import ZifyClasses ZifyInst. -Require Zify. - -(* [elim_let] replaces a let binding (x := e : t) - by an equation (x = e) if t is an injected type *) - -Ltac elim_binding x t ty := - let h := fresh "heq_" x in - pose proof (@eq_refl ty x : @eq ty x t) as h; - try clearbody x. - -Ltac elim_let := zify_iter_let elim_binding. - -Ltac zify := - intros ; elim_let ; - Zify.zify ; ZifyInst.zify_saturate. diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v deleted file mode 100644 index 6b92445326..0000000000 --- a/plugins/rtauto/Bintree.v +++ /dev/null @@ -1,385 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export List. -Require Export BinPos. -Require Arith.EqNat. - -Open Scope positive_scope. - -Ltac clean := try (simpl; congruence). - -Lemma Gt_Psucc: forall p q, - (p ?= Pos.succ q) = Gt -> (p ?= q) = Gt. -Proof. -intros. rewrite <- Pos.compare_succ_succ. -now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt. -Qed. - -Lemma Psucc_Gt : forall p, - (Pos.succ p ?= p) = Gt. -Proof. -intros. apply Pos.lt_gt, Pos.lt_succ_diag_r. -Qed. - -Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := -match l with nil => None -| x::q => -match n with O => Some x -| S m => Lget A m q -end end . - -Arguments Lget [A] n l. - -Lemma map_app : forall (A B:Set) (f:A -> B) l m, -List.map f (l ++ m) = List.map f l ++ List.map f m. -induction l. -reflexivity. -simpl. -intro m ; apply f_equal;apply IHl. -Qed. - -Lemma length_map : forall (A B:Set) (f:A -> B) l, -length (List.map f l) = length l. -induction l. -reflexivity. -simpl; apply f_equal;apply IHl. -Qed. - -Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, -Lget i (List.map f l) = -match Lget i l with Some a => -Some (f a) | None => None end. -induction i;intros [ | x l ] ;trivial. -simpl;auto. -Qed. - -Lemma Lget_app : forall (A:Set) (a:A) l i, -Lget i (l ++ a :: nil) = if Arith.EqNat.beq_nat i (length l) then Some a else Lget i l. -Proof. -induction l;simpl Lget;simpl length. -intros [ | i];simpl;reflexivity. -intros [ | i];simpl. -reflexivity. -auto. -Qed. - -Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), -Lget i l = Some a -> -Lget i (l ++ delta) = Some a. -induction l;destruct i;simpl;try congruence;auto. -Qed. - -Inductive Poption {A} : Type:= - PSome : A -> Poption -| PNone : Poption. -Arguments Poption : clear implicits. - -Inductive Tree {A} : Type := - Tempty : Tree - | Branch0 : Tree -> Tree -> Tree - | Branch1 : A -> Tree -> Tree -> Tree. -Arguments Tree : clear implicits. - -Section Store. - -Variable A:Type. - -Notation Poption := (Poption A). -Notation Tree := (Tree A). - - -Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := - match T with - Tempty => PNone - | Branch0 T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PNone - end - | Branch1 a T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PSome a - end -end. - -Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := - match T with - | Tempty => - match p with - | xI pp => Branch0 Tempty (Tadd pp a Tempty) - | xO pp => Branch0 (Tadd pp a Tempty) Tempty - | xH => Branch1 a Tempty Tempty - end - | Branch0 T1 T2 => - match p with - | xI pp => Branch0 T1 (Tadd pp a T2) - | xO pp => Branch0 (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tadd pp a T2) - | xO pp => Branch1 b (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - end. - -Definition mkBranch0 (T1 T2:Tree) := - match T1,T2 with - Tempty ,Tempty => Tempty - | _,_ => Branch0 T1 T2 - end. - -Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := - match T with - | Tempty => Tempty - | Branch0 T1 T2 => - match p with - | xI pp => mkBranch0 T1 (Tremove pp T2) - | xO pp => mkBranch0 (Tremove pp T1) T2 - | xH => T - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tremove pp T2) - | xO pp => Branch1 b (Tremove pp T1) T2 - | xH => mkBranch0 T1 T2 - end - end. - - -Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. -destruct p;reflexivity. -Qed. - -Theorem Tget_Tadd: forall i j a T, - Tget i (Tadd j a T) = - match (i ?= j) with - Eq => PSome a - | Lt => Tget i T - | Gt => Tget i T - end. -Proof. -intros i j. -case_eq (i ?= j). -intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H. -induction j;destruct T;simpl;try (apply IHj);congruence. -unfold Pos.compare. -generalize i;clear i;induction j;destruct T;simpl in H|-*; -destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -unfold Pos.compare. -generalize i;clear i;induction j;destruct T;simpl in H|-*; -destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -Qed. - -Record Store : Type := -mkStore {index:positive;contents:Tree}. - -Definition empty := mkStore xH Tempty. - -Definition push a S := -mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)). - -Definition get i S := Tget i (contents S). - -Lemma get_empty : forall i, get i empty = PNone. -intro i; case i; unfold empty,get; simpl;reflexivity. -Qed. - -Inductive Full : Store -> Type:= - F_empty : Full empty - | F_push : forall a S, Full S -> Full (push a S). - -Theorem get_Full_Gt : forall S, Full S -> - forall i, (i ?= index S) = Gt -> get i S = PNone. -Proof. -intros S W;induction W. -unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push. simpl @contents. -intros i e;rewrite Tget_Tadd. -rewrite (Gt_Psucc _ _ e). -unfold get in IHW. -apply IHW;apply Gt_Psucc;assumption. -Qed. - -Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. -intros [index0 contents0] F. -case F. -unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold push,index,get;simpl @contents. -intros a S. -rewrite Tget_Tadd. -rewrite Psucc_Gt. -intro W. -change (get (Pos.succ (index S)) S =PNone). -apply get_Full_Gt; auto. -apply Psucc_Gt. -Qed. - -Theorem get_push_Full : - forall i a S, Full S -> - get i (push a S) = - match (i ?= index S) with - Eq => PSome a - | Lt => get i S - | Gt => PNone -end. -Proof. -intros i a S F. -case_eq (i ?= index S). -intro e;rewrite (Pos.compare_eq _ _ e). -destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. -rewrite Pos.compare_refl;reflexivity. -intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd. -simpl @index in H;rewrite H;reflexivity. -intro H;generalize H;clear H. -unfold get,push;simpl. -rewrite Tget_Tadd;intro e;rewrite e. -change (get i S=PNone). -apply get_Full_Gt;auto. -Qed. - -Lemma Full_push_compat : forall i a S, Full S -> -forall x, get i S = PSome x -> - get i (push a S) = PSome x. -Proof. -intros i a S F x H. -case_eq (i ?= index S);intro test. -rewrite (Pos.compare_eq _ _ test) in H. -rewrite (get_Full_Eq _ F) in H;congruence. -rewrite <- H. -rewrite (get_push_Full i a). -rewrite test;reflexivity. -assumption. -rewrite (get_Full_Gt _ F) in H;congruence. -Qed. - -Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. -intros [ind cont] F one; inversion F. -reflexivity. -simpl @index in one;assert (h:=Pos.succ_not_1 (index S)). -congruence. -Qed. - -Lemma push_not_empty: forall a S, (push a S) <> empty. -intros a [ind cont];unfold push,empty. -intros [= H%Pos.succ_not_1]. assumption. -Qed. - -Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := -match F with -F_empty => False -| F_push a SS FF => x=a \/ In x SS FF -end. - -Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , -get i S = PSome x -> In x S F. -induction F. -intro i;rewrite get_empty; congruence. -intro i;rewrite get_push_Full;trivial. -case_eq (i ?= index S);simpl. -left;congruence. -right;eauto. -congruence. -Qed. - -End Store. - -Arguments PNone {A}. -Arguments PSome [A] _. - -Arguments Tempty {A}. -Arguments Branch0 [A] _ _. -Arguments Branch1 [A] _ _ _. - -Arguments Tget [A] p T. -Arguments Tadd [A] p a T. - -Arguments Tget_Tempty [A] p. -Arguments Tget_Tadd [A] i j a T. - -Arguments mkStore [A] index contents. -Arguments index [A] s. -Arguments contents [A] s. - -Arguments empty {A}. -Arguments get [A] i S. -Arguments push [A] a S. - -Arguments get_empty [A] i. -Arguments get_push_Full [A] i a S _. - -Arguments Full [A] _. -Arguments F_empty {A}. -Arguments F_push [A] a S _. -Arguments In [A] x S F. - -Register empty as plugins.rtauto.empty. -Register push as plugins.rtauto.push. - -Section Map. - -Variables A B:Set. - -Variable f: A -> B. - -Fixpoint Tmap (T: Tree A) : Tree B := -match T with -Tempty => Tempty -| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) -| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) -end. - -Lemma Tget_Tmap: forall T i, -Tget i (Tmap T)= match Tget i T with PNone => PNone -| PSome a => PSome (f a) end. -induction T;intro i;case i;simpl;auto. -Defined. - -Lemma Tmap_Tadd: forall i a T, -Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). -induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. -Defined. - -Definition map (S:Store A) : Store B := -mkStore (index S) (Tmap (contents S)). - -Lemma get_map: forall i S, -get i (map S)= match get i S with PNone => PNone -| PSome a => PSome (f a) end. -destruct S;unfold get,map,contents,index;apply Tget_Tmap. -Defined. - -Lemma map_push: forall a S, -map (push a S) = push (f a) (map S). -intros a S. -case S. -unfold push,map,contents,index. -intros;rewrite Tmap_Tadd;reflexivity. -Defined. - -Theorem Full_map : forall S, Full S -> Full (map S). -intros S F. -induction F. -exact F_empty. -rewrite map_push;constructor 2;assumption. -Defined. - -End Map. - -Arguments Tmap [A B] f T. -Arguments map [A B] f S. -Arguments Full_map [A B f] S _. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v deleted file mode 100644 index 2e9b4347b9..0000000000 --- a/plugins/rtauto/Rtauto.v +++ /dev/null @@ -1,410 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -Require Export List. -Require Export Bintree. -Require Import Bool BinPos. - -Declare ML Module "rtauto_plugin". - -Ltac clean:=try (simpl;congruence). - -Inductive form:Set:= - Atom : positive -> form -| Arrow : form -> form -> form -| Bot -| Conjunct : form -> form -> form -| Disjunct : form -> form -> form. - -Notation "[ n ]":=(Atom n). -Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). -Notation "#" := Bot. -Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). -Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). - -Definition ctx := Store form. - -Fixpoint pos_eq (m n:positive) {struct m} :bool := -match m with - xI mm => match n with xI nn => pos_eq mm nn | _ => false end -| xO mm => match n with xO nn => pos_eq mm nn | _ => false end -| xH => match n with xH => true | _ => false end -end. - -Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. -induction m;simpl;destruct n;congruence || -(intro e;apply f_equal;auto). -Qed. - -Fixpoint form_eq (p q:form) {struct p} :bool := -match p with - Atom m => match q with Atom n => pos_eq m n | _ => false end -| Arrow p1 p2 => -match q with - Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false end -| Bot => match q with Bot => true | _ => false end -| Conjunct p1 p2 => -match q with - Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -| Disjunct p1 p2 => -match q with - Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -end. - -Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. -induction p;destruct q;simpl;clean. -intro h;generalize (pos_eq_refl _ _ h);congruence. -case_eq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -case_eq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -case_eq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -Qed. - -Arguments form_eq_refl [p q] _. - -Section with_env. - -Variable env:Store Prop. - -Fixpoint interp_form (f:form): Prop := -match f with -[n]=> match get n env with PNone => True | PSome P => P end -| A =>> B => (interp_form A) -> (interp_form B) -| # => False -| A //\\ B => (interp_form A) /\ (interp_form B) -| A \\// B => (interp_form A) \/ (interp_form B) -end. - -Notation "[[ A ]]" := (interp_form A). - -Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := -match F with - F_empty => G -| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) -end. - -Ltac wipe := intros;simpl;constructor. - -Lemma compose0 : -forall hyps F (A:Prop), - A -> - (interp_ctx hyps F A). -induction F;intros A H;simpl;auto. -Qed. - -Lemma compose1 : -forall hyps F (A B:Prop), - (A -> B) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B). -induction F;intros A B H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose2 : -forall hyps F (A B C:Prop), - (A -> B -> C) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C). -induction F;intros A B C H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose3 : -forall hyps F (A B C D:Prop), - (A -> B -> C -> D) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C) -> - (interp_ctx hyps F D). -induction F;intros A B C D H;simpl;auto. -apply IHF;auto. -Qed. - -Lemma weaken : forall hyps F f G, - (interp_ctx hyps F G) -> - (interp_ctx (hyps\f) (F_push f hyps F) G). -induction F;simpl;intros;auto. -apply compose1 with ([[a]]-> G);auto. -Qed. - -Theorem project_In : forall hyps F g, -In g hyps F -> -interp_ctx hyps F [[g]]. -induction F;simpl. -contradiction. -intros g H;destruct H. -subst;apply compose0;simpl;trivial. -apply compose1 with [[g]];auto. -Qed. - -Theorem project : forall hyps F p g, -get p hyps = PSome g-> -interp_ctx hyps F [[g]]. -intros hyps F p g e; apply project_In. -apply get_In with p;assumption. -Qed. - -Arguments project [hyps] F [p g] _. - -Inductive proof:Set := - Ax : positive -> proof -| I_Arrow : proof -> proof -| E_Arrow : positive -> positive -> proof -> proof -| D_Arrow : positive -> proof -> proof -> proof -| E_False : positive -> proof -| I_And: proof -> proof -> proof -| E_And: positive -> proof -> proof -| D_And: positive -> proof -> proof -| I_Or_l: proof -> proof -| I_Or_r: proof -> proof -| E_Or: positive -> proof -> proof -> proof -| D_Or: positive -> proof -> proof -| Cut: form -> proof -> proof -> proof. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). - -Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := - match P with - Ax i => - match get i hyps with - PSome F => form_eq F gl - | _ => false - end -| I_Arrow p => - match gl with - A =>> B => check_proof (hyps \ A) B p - | _ => false - end -| E_Arrow i j p => - match get i hyps,get j hyps with - PSome A,PSome (B =>>C) => - form_eq A B && check_proof (hyps \ C) (gl) p - | _,_ => false - end -| D_Arrow i p1 p2 => - match get i hyps with - PSome ((A =>>B)=>>C) => - (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) - | _ => false - end -| E_False i => - match get i hyps with - PSome # => true - | _ => false - end -| I_And p1 p2 => - match gl with - A //\\ B => - check_proof hyps A p1 && check_proof hyps B p2 - | _ => false - end -| E_And i p => - match get i hyps with - PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p - | _=> false - end -| D_And i p => - match get i hyps with - PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p - | _=> false - end -| I_Or_l p => - match gl with - (A \\// B) => check_proof hyps A p - | _ => false - end -| I_Or_r p => - match gl with - (A \\// B) => check_proof hyps B p - | _ => false - end -| E_Or i p1 p2 => - match get i hyps with - PSome (A \\// B) => - check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 - | _=> false - end -| D_Or i p => - match get i hyps with - PSome (A \\// B =>> C) => - (check_proof (hyps \ A=>>C \ B=>>C) gl p) - | _=> false - end -| Cut A p1 p2 => - check_proof hyps A p1 && check_proof (hyps \ A) gl p2 -end. - -Theorem interp_proof: -forall p hyps F gl, -check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. - -induction p; intros hyps F gl. - -- (* Axiom *) - simpl;case_eq (get p hyps);clean. - intros f nth_f e;rewrite <- (form_eq_refl e). - apply project with p;trivial. - -- (* Arrow_Intro *) - destruct gl; clean. - simpl; intros. - change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). - apply IHp; try constructor; trivial. - -- (* Arrow_Elim *) - simpl check_proof; case_eq (get p hyps); clean. - intros f ef; case_eq (get p0 hyps); clean. - intros f0 ef0; destruct f0; clean. - case_eq (form_eq f f0_1); clean. - simpl; intros e check_p1. - generalize (project F ef) (project F ef0) - (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); - clear check_p1 IHp p p0 p1 ef ef0. - simpl. - apply compose3. - rewrite (form_eq_refl e). - auto. - -- (* Arrow_Destruct *) - simpl; case_eq (get p1 hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2); clean. - intros check_p1 check_p2. - generalize (project F ef) - (IHp1 (hyps \ f1_2 =>> f2 \ f1_1) - (F_push f1_1 (hyps \ f1_2 =>> f2) - (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) - (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). - simpl; apply compose3; auto. - -- (* False_Elim *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - intros _; generalize (project F ef). - apply compose1; apply False_ind. - -- (* And_Intro *) - simpl; destruct gl; clean. - case_eq (check_proof hyps gl1 p1); clean. - intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). - apply compose2 ; simpl; auto. - -- (* And_Elim *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - intro check_p; - generalize (project F ef) - (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). - simpl; apply compose2; intros [h1 h2]; auto. - -- (* And_Destruct*) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - intro H; - generalize (project F ef) - (IHp (hyps \ f1_1 =>> f1_2 =>> f2) - (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H); - clear H; simpl. - apply compose2; auto. - -- (* Or_Intro_left *) - destruct gl; clean. - intro Hp; generalize (IHp hyps F gl1 Hp). - apply compose1; simpl; auto. - -- (* Or_Intro_right *) - destruct gl; clean. - intro Hp; generalize (IHp hyps F gl2 Hp). - apply compose1; simpl; auto. - -- (* Or_elim *) - simpl; case_eq (get p1 hyps); clean. - intros f ef; destruct f; clean. - case_eq (check_proof (hyps \ f1) gl p2); clean. - intros check_p1 check_p2; - generalize (project F ef) - (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) - (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); - simpl; apply compose3; simpl; intro h; destruct h; auto. - -- (* Or_Destruct *) - simpl; case_eq (get p hyps); clean. - intros f ef; destruct f; clean. - destruct f1; clean. - intro check_p0; - generalize (project F ef) - (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) - (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) - (F_push (f1_1 =>> f2) hyps F)) gl check_p0); - simpl. - apply compose2; auto. - -- (* Cut *) - simpl; case_eq (check_proof hyps f p1); clean. - intros check_p1 check_p2; - generalize (IHp1 hyps F f check_p1) - (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); - simpl; apply compose2; auto. -Qed. - -Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. -intros gl prf;case_eq (check_proof empty gl prf);intro check_prf. -change (interp_ctx empty F_empty [[gl]]) ; -apply interp_proof with prf;assumption. -trivial. -Qed. - -End with_env. - -(* -(* A small example *) -Parameters A B C D:Prop. -Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). -exact (Reflect (empty \ A \ B \ C) -([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) -(I_Arrow (E_And 1 (E_Or 3 - (I_Or_l (I_And (Ax 2) (Ax 4))) - (I_Or_r (I_And (Ax 2) (Ax 4))))))). -Qed. -Print toto. -*) - -Register Reflect as plugins.rtauto.Reflect. - -Register Atom as plugins.rtauto.Atom. -Register Arrow as plugins.rtauto.Arrow. -Register Bot as plugins.rtauto.Bot. -Register Conjunct as plugins.rtauto.Conjunct. -Register Disjunct as plugins.rtauto.Disjunct. - -Register Ax as plugins.rtauto.Ax. -Register I_Arrow as plugins.rtauto.I_Arrow. -Register E_Arrow as plugins.rtauto.E_Arrow. -Register D_Arrow as plugins.rtauto.D_Arrow. -Register E_False as plugins.rtauto.E_False. -Register I_And as plugins.rtauto.I_And. -Register E_And as plugins.rtauto.E_And. -Register D_And as plugins.rtauto.D_And. -Register I_Or_l as plugins.rtauto.I_Or_l. -Register I_Or_r as plugins.rtauto.I_Or_r. -Register E_Or as plugins.rtauto.E_Or. -Register D_Or as plugins.rtauto.D_Or. diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v deleted file mode 100644 index 5f594d29cd..0000000000 --- a/plugins/setoid_ring/Algebra_syntax.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Class Zero (A : Type) := zero : A. -Notation "0" := zero. -Class One (A : Type) := one : A. -Notation "1" := one. -Class Addition (A : Type) := addition : A -> A -> A. -Notation "_+_" := addition. -Notation "x + y" := (addition x y). -Class Multiplication {A B : Type} := multiplication : A -> B -> B. -Notation "_*_" := multiplication. -Notation "x * y" := (multiplication x y). -Class Subtraction (A : Type) := subtraction : A -> A -> A. -Notation "_-_" := subtraction. -Notation "x - y" := (subtraction x y). -Class Opposite (A : Type) := opposite : A -> A. -Notation "-_" := opposite. -Notation "- x" := (opposite(x)). -Class Equality {A : Type}:= equality : A -> A -> Prop. -Notation "_==_" := equality. -Notation "x == y" := (equality x y) (at level 70, no associativity). -Class Bracket (A B: Type):= bracket : A -> B. -Notation "[ x ]" := (bracket(x)). -Class Power {A B: Type} := power : A -> B -> A. -Notation "x ^ y" := (power x y). - diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v deleted file mode 100644 index 727e99f0b4..0000000000 --- a/plugins/setoid_ring/ArithRing.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Mult. -Require Import BinNat. -Require Import Nnat. -Require Export Ring. -Set Implicit Arguments. - -Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). - Proof. - constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. - exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. - Qed. - -Lemma nat_morph_N : - semi_morph 0 1 plus mult (eq (A:=nat)) - 0%N 1%N N.add N.mul N.eqb N.to_nat. -Proof. - constructor;trivial. - exact N2Nat.inj_add. - exact N2Nat.inj_mul. - intros x y H. apply N.eqb_eq in H. now subst. -Qed. - -Ltac natcst t := - match isnatcst t with - true => constr:(N.of_nat t) - | _ => constr:(InitialRing.NotConstant) - end. - -Ltac Ss_to_add f acc := - match f with - | S ?f1 => Ss_to_add f1 (S acc) - | _ => constr:((acc + f)%nat) - end. - -(* For internal use only *) -Local Definition protected_to_nat := N.to_nat. - -Ltac natprering := - match goal with - |- context C [S ?p] => - match p with - O => fail 1 (* avoid replacing 1 with 1+0 ! *) - | p => match isnatcst p with - | true => fail 1 - | false => let v := Ss_to_add p (S 0) in - fold v; natprering - end - end - | _ => change N.to_nat with protected_to_nat - end. - -Ltac natpostring := - match goal with - | |- context [N.to_nat ?x] => - let v := eval cbv in (N.to_nat x) in - change (N.to_nat x) with v; - natpostring - | _ => change protected_to_nat with N.to_nat - end. - -Add Ring natr : natSRth - (morphism nat_morph_N, constants [natcst], - preprocess [natprering], postprocess [natpostring]). - diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v deleted file mode 100644 index 958832274b..0000000000 --- a/plugins/setoid_ring/BinList.v +++ /dev/null @@ -1,82 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import BinPos. -Require Export List. -Set Implicit Arguments. -Local Open Scope positive_scope. - -Section MakeBinList. - Variable A : Type. - Variable default : A. - - Fixpoint jump (p:positive) (l:list A) {struct p} : list A := - match p with - | xH => tl l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tl l)) - end. - - Fixpoint nth (p:positive) (l:list A) {struct p} : A:= - match p with - | xH => hd default l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tl l)) - end. - - Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). - Proof. - induction j;simpl;intros; now rewrite ?IHj. - Qed. - - Lemma jump_succ : forall j l, - jump (Pos.succ j) l = jump 1 (jump j l). - Proof. - induction j;simpl;intros. - - rewrite !IHj; simpl; now rewrite !jump_tl. - - now rewrite !jump_tl. - - trivial. - Qed. - - Lemma jump_add : forall i j l, - jump (i + j) l = jump i (jump j l). - Proof. - induction i using Pos.peano_ind; intros. - - now rewrite Pos.add_1_l, jump_succ. - - now rewrite Pos.add_succ_l, !jump_succ, IHi. - Qed. - - Lemma jump_pred_double : forall i l, - jump (Pos.pred_double i) (tl l) = jump i (jump i l). - Proof. - induction i;intros;simpl. - - now rewrite !jump_tl. - - now rewrite IHi, <- 2 jump_tl, IHi. - - trivial. - Qed. - - Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). - Proof. - induction p;simpl;intros. - - now rewrite <-jump_tl, IHp. - - now rewrite <-jump_tl, IHp. - - trivial. - Qed. - - Lemma nth_pred_double : - forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). - Proof. - induction p;simpl;intros. - - now rewrite !jump_tl. - - now rewrite jump_pred_double, <- !jump_tl, IHp. - - trivial. - Qed. - -End MakeBinList. diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v deleted file mode 100644 index df0313a624..0000000000 --- a/plugins/setoid_ring/Cring.v +++ /dev/null @@ -1,275 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export List. -Require Import Setoid. -Require Import BinPos. -Require Import BinList. -Require Import Znumtheory. -Require Export Morphisms Setoid Bool. -Require Import ZArith_base. -Require Export Algebra_syntax. -Require Export Ncring. -Require Export Ncring_initial. -Require Export Ncring_tac. -Require Import InitialRing. - -Class Cring {R:Type}`{Rr:Ring R} := - cring_mul_comm: forall x y:R, x * y == y * x. - - -Ltac reify_goal lvar lexpr lterm:= - (*idtac lvar; idtac lexpr; idtac lterm;*) - match lexpr with - nil => idtac - | ?e1::?e2::_ => - match goal with - |- (?op ?u1 ?u2) => - change (op - (@Ring_polynom.PEeval - _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) lvar e1) - (@Ring_polynom.PEeval - _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) - end - end. - -Section cring. -Context {R:Type}`{Rr:Cring R}. - -Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_. -Proof. -intros. apply mk_reqe; solve_proper. -Defined. - -Lemma cring_almost_ring_theory: - almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_. -intros. apply mk_art ;intros. -rewrite ring_add_0_l; reflexivity. -rewrite ring_add_comm; reflexivity. -rewrite ring_add_assoc; reflexivity. -rewrite ring_mul_1_l; reflexivity. -apply ring_mul_0_l. -rewrite cring_mul_comm; reflexivity. -rewrite ring_mul_assoc; reflexivity. -rewrite ring_distr_l; reflexivity. -rewrite ring_opp_mul_l; reflexivity. -apply ring_opp_add. -rewrite ring_sub_def ; reflexivity. Defined. - -Lemma cring_morph: - ring_morph zero one _+_ _*_ _-_ -_ _==_ - 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool - Ncring_initial.gen_phiZ. -intros. apply mkmorph ; intros; simpl; try reflexivity. -rewrite Ncring_initial.gen_phiZ_add; reflexivity. -rewrite ring_sub_def. unfold Z.sub. rewrite Ncring_initial.gen_phiZ_add. -rewrite Ncring_initial.gen_phiZ_opp; reflexivity. -rewrite Ncring_initial.gen_phiZ_mul; reflexivity. -rewrite Ncring_initial.gen_phiZ_opp; reflexivity. -rewrite (Zeqb_ok x y H). reflexivity. Defined. - -Lemma cring_power_theory : - @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication). -intros; apply Ring_theory.mkpow_th. reflexivity. Defined. - -Lemma cring_div_theory: - div_theory _==_ Z.add Z.mul Ncring_initial.gen_phiZ Z.quotrem. -intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory. -simpl. apply ring_setoid. Defined. - -End cring. - -Ltac cring_gen := - match goal with - |- ?g => let lterm := lterm_goal g in - match eval red in (list_reifyl (lterm:=lterm)) with - | (?fv, ?lexpr) => - (*idtac "variables:";idtac fv; - idtac "terms:"; idtac lterm; - idtac "reifications:"; idtac lexpr; *) - reify_goal fv lexpr lterm; - match goal with - |- ?g => - generalize - (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_ - ring_setoid - cring_eq_ext - cring_almost_ring_theory - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool - Ncring_initial.gen_phiZ - cring_morph - N - (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) - cring_power_theory - Z.quotrem - cring_div_theory - O fv nil); - let rc := fresh "rc"in - intro rc; apply rc - end - end - end. - -Ltac cring_compute:= vm_compute; reflexivity. - -Ltac cring:= - intros; - cring_gen; - cring_compute. - -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -(* Cring_simplify *) - -Ltac cring_simplify_aux lterm fv lexpr hyp := - match lterm with - | ?t0::?lterm => - match lexpr with - | ?e::?le => - let t := constr:(@Ring_polynom.norm_subst - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Z.quotrem O nil e) in - let te := - constr:(@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - - Z 0%Z 1%Z Zeq_bool - Ncring_initial.gen_phiZ - get_signZ fv t) in - let eq1 := fresh "ring" in - let nft := eval vm_compute in t in - let t':= fresh "t" in - pose (t' := nft); - assert (eq1 : t = t'); - [vm_cast_no_check (eq_refl t')| - let eq2 := fresh "ring" in - assert (eq2:(@Ring_polynom.PEeval - _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); - [let eq3 := fresh "ring" in - generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_ - ring_setoid - cring_eq_ext - cring_almost_ring_theory - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool - Ncring_initial.gen_phiZ - cring_morph - N - (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) - cring_power_theory - Z.quotrem - cring_div_theory - get_signZ get_signZ_th - O nil fv I nil (eq_refl nil) ); - intro eq3; apply eq3; reflexivity| - match hyp with - | 1%nat => rewrite eq2 - | ?H => try rewrite eq2 in H - end]; - let P:= fresh "P" in - match hyp with - | 1%nat => - rewrite eq1; - pattern (@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - - Z 0%Z 1%Z Zeq_bool - Ncring_initial.gen_phiZ - get_signZ fv t'); - match goal with - |- (?p ?t) => set (P:=p) - end; - unfold t' in *; clear t' eq1 eq2; - unfold Pphi_dev, Pphi_avoid; simpl; - repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, - mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, - mkpow;simpl) - | ?H => - rewrite eq1 in H; - pattern (@Ring_polynom.Pphi_dev - _ 0 1 _+_ _*_ _-_ -_ - - Z 0%Z 1%Z Zeq_bool - Ncring_initial.gen_phiZ - get_signZ fv t') in H; - match type of H with - | (?p ?t) => set (P:=p) in H - end; - unfold t' in *; clear t' eq1 eq2; - unfold Pphi_dev, Pphi_avoid in H; simpl in H; - repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, - mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, - mkpow in H;simpl in H) - end; unfold P in *; clear P - ]; cring_simplify_aux lterm fv le hyp - | nil => idtac - end - | nil => idtac - end. - -Ltac set_variables fv := - match fv with - | nil => idtac - | ?t::?fv => - let v := fresh "X" in - set (v:=t) in *; set_variables fv - end. - -Ltac deset n:= - match n with - | 0%nat => idtac - | S ?n1 => - match goal with - | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 - end - end. - -(* a est soit un terme de l'anneau, soit une liste de termes. -J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list - dans Tactic Notation *) - -Ltac cring_simplify_gen a hyp := - let lterm := - match a with - | _::_ => a - | _ => constr:(a::nil) - end in - match eval red in (list_reifyl (lterm:=lterm)) with - | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; - let n := eval compute in (length fv) in - idtac n; - let lt:=fresh "lt" in - set (lt:= lterm); - let lv:=fresh "fv" in - set (lv:= fv); - (* les termes de fv sont remplacés par des variables - pour pouvoir utiliser simpl ensuite sans risquer - des simplifications indésirables *) - set_variables fv; - let lterm1 := eval unfold lt in lt in - let lv1 := eval unfold lv in lv in - idtac lterm1; idtac lv1; - cring_simplify_aux lterm1 lv1 lexpr hyp; - clear lt lv; - (* on remet les termes de fv *) - deset n - end. - -Tactic Notation "cring_simplify" constr(lterm):= - cring_simplify_gen lterm 1%nat. - -Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):= - cring_simplify_gen lterm H. - diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v deleted file mode 100644 index 9ff07948df..0000000000 --- a/plugins/setoid_ring/Field.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Field_theory. -Require Export Field_tac. diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v deleted file mode 100644 index a5390efc7f..0000000000 --- a/plugins/setoid_ring/Field_tac.v +++ /dev/null @@ -1,584 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Ring_tac BinList Ring_polynom InitialRing. -Require Export Field_theory. - - (* syntaxification *) - (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) - (* the tactic could be used to discriminate occurrences of an opaque *) - (* constant phi, with (phi 0) not convertible to 0 for instance *) - Ltac mkFieldexpr C Cst CstPow rO rI radd rmul rsub ropp rdiv rinv rpow t fv := - let rec mkP t := - let f := - match Cst t with - | InitialRing.NotConstant => - match t with - | rO => - fun _ => constr:(@FEO C) - | rI => - fun _ => constr:(@FEI C) - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEadd C e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEmul C e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEsub C e1 e2) - | (ropp ?t1) => - fun _ => let e1 := mkP t1 in constr:(@FEopp C e1) - | (rdiv ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@FEdiv C e1 e2) - | (rinv ?t1) => - fun _ => let e1 := mkP t1 in constr:(@FEinv C e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - fun _ => - let p := Find_at t fv in - constr:(@FEX C p) - | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c) - end - | _ => - fun _ => - let p := Find_at t fv in - constr:(@FEX C p) - end - | ?c => fun _ => constr:(@FEc C c) - end in - f () - in mkP t. - - (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) - (* the tactic could be used to discriminate occurrences of an opaque *) - (* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv := - let rec TFV t fv := - match Cst t with - | InitialRing.NotConstant => - match t with - | rO => fv - | rI => fv - | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => TFV t1 fv - | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (inv ?t1) => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - AddFvTail t fv - | _ => TFV t1 fv - end - | _ => AddFvTail t fv - end - | _ => fv - end - in TFV t fv. - -(* packaging the field structure *) - -(* TODO: inline PackField into field_lookup *) -Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := - let FLD := - match type of L1 with - | context [req (@FEeval ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv - ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => - (fun proj => - proj Cst_tac Pow_tac pre post - req rO rI radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - end in - F FLD. - -Ltac get_FldPre FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - pre). - -Ltac get_FldPost FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - post). - -Ltac get_L1 FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L1). - -Ltac get_SimplifyEqLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L2). - -Ltac get_SimplifyLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L3). - -Ltac get_L4 FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - L4). - -Ltac get_CondLemma FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - cond_ok). - -Ltac get_FldEq FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - req). - -Ltac get_FldCarrier FLD := - let req := get_FldEq FLD in - relation_carrier req. - -Ltac get_RingFV FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - FV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). - -Ltac get_FFV FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - FFV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). - -Ltac get_RingMeta FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow). - -Ltac get_Meta FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - mkFieldexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow). - -Ltac get_Hyp_tac FLD := - FLD ltac: - (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C - L1 L2 L3 L4 cond_ok => - let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in - fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). - -Ltac get_FEeval FLD := - let L1 := get_L1 FLD in - match type of L1 with - | context - [(@FEeval - ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => - constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow) - | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" - end. - -(* simplifying the non-zero condition... *) - -Ltac fold_field_cond req := - let rec fold_concl t := - match t with - ?x /\ ?y => - let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) - | req ?x ?y -> False => constr:(~ req x y) - | _ => t - end in - let ft := fold_concl Get_goal in - change ft. - -Ltac simpl_PCond FLD := - let req := get_FldEq FLD in - let lemma := get_CondLemma FLD in - try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); - protect_fv "field_cond"; - fold_field_cond req; - try exact I. - -Ltac simpl_PCond_BEURK FLD := - let req := get_FldEq FLD in - let lemma := get_CondLemma FLD in - (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); - protect_fv "field_cond"; - fold_field_cond req. - -(* Rewriting (field_simplify) *) -Ltac Field_norm_gen f n FLD lH rl := - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in - let lemma_tac fv kont := - let lemma := get_SimplifyLemma FLD in - (* reify equations of the context *) - let lpe := get_Hyp_tac FLD fv lH in - let vlpe := fresh "hyps" in - pose (vlpe := lpe); - let prh := proofHyp_tac lH in - (* compute the normal form of the reified hyps *) - let vlmp := fresh "hyps'" in - let vlmp_eq := fresh "hyps_eq" in - let mk_monpol := get_MonPol lemma in - compute_assertion vlmp_eq vlmp (mk_monpol vlpe); - (* partially instantiate the lemma *) - let lem := fresh "f_rw_lemma" in - (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq) - || fail "type error when building the rewriting lemma"); - (* continuation will call main_tac for all reified terms *) - kont lem; - (* at the end, cleanup *) - (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in - (* each instance of the lemma is simplified then passed to f *) - let main_tac H := protect_fv "field" in H; f H in - (* generate and use equations for each expression *) - ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; - try simpl_PCond FLD. - -Ltac Field_simplify_gen f FLD lH rl := - get_FldPre FLD (); - Field_norm_gen f ring_subst_niter FLD lH rl; - get_FldPost FLD (). - -Ltac Field_simplify := - Field_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "field_simplify" constr_list(rl) := - let G := Get_goal in - field_lookup (PackField Field_simplify) [] rl G. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - field_lookup (PackField Field_simplify) [lH] rl G. - -Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - revert H; - field_lookup (PackField Field_simplify) [] rl t; - intro H; - unfold g;clear g. - -Tactic Notation "field_simplify" - "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - revert H; - field_lookup (PackField Field_simplify) [lH] rl t; - intro H; - unfold g;clear g. - -(* -Ltac Field_simplify_in hyp:= - Field_simplify_gen ltac:(fun H => rewrite H in hyp). - -Tactic Notation (at level 0) - "field_simplify" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [] rl t. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [lH] rl t. -*) - -(** Generic tactic for solving equations *) - -Ltac Field_Scheme Simpl_tac n lemma FLD lH := - let req := get_FldEq FLD in - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let Main_eq t1 t2 := - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := get_Hyp_tac FLD fv lH in - let prh := proofHyp_tac lH in - let vlpe := fresh "list_hyp" in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - pose (vlpe := lpe); - let nlemma := fresh "field_lemma" in - (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) - || fail "field anomaly:failed to build lemma"); - ProveLemmaHyps nlemma - ltac:(fun ilemma => - apply ilemma - || fail "field anomaly: failed in applying lemma"; - [ Simpl_tac | simpl_PCond FLD]); - clear nlemma; - subst vlpe in - OnEquation req Main_eq. - -(* solve completely a field equation, leaving non-zero conditions to be - proved (field) *) - -Ltac FIELD FLD lH rl := - let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in - let lemma := get_L1 FLD in - get_FldPre FLD (); - Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; - try exact I; - get_FldPost FLD(). - -Tactic Notation (at level 0) "field" := - let G := Get_goal in - field_lookup (PackField FIELD) [] G. - -Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup (PackField FIELD) [lH] G. - -(* transforms a field equation to an equivalent (simplified) ring equation, - and leaves non-zero conditions to be proved (field_simplify_eq) *) -Ltac FIELD_SIMPL FLD lH rl := - let Simpl := (protect_fv "field") in - let lemma := get_SimplifyEqLemma FLD in - get_FldPre FLD (); - Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; - get_FldPost FLD (). - -Tactic Notation (at level 0) "field_simplify_eq" := - let G := Get_goal in - field_lookup (PackField FIELD_SIMPL) [] G. - -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup (PackField FIELD_SIMPL) [lH] G. - -(* Same as FIELD_SIMPL but in hypothesis *) - -Ltac Field_simplify_eq n FLD lH := - let req := get_FldEq FLD in - let mkFV := get_RingFV FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let lemma := get_L4 FLD in - let hyp := fresh "hyp" in - intro hyp; - OnEquationHyp req hyp ltac:(fun t1 t2 => - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := get_Hyp_tac FLD fv lH in - let prh := proofHyp_tac lH in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - let vlpe := fresh "vlpe" in - ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) - ltac:(fun ilemma => - match type of ilemma with - | req _ _ -> _ -> ?EQ => - let tmp := fresh "tmp" in - assert (tmp : EQ); - [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] - | protect_fv "field" in tmp; revert tmp ]; - clear hyp - end)). - -Ltac FIELD_SIMPL_EQ FLD lH rl := - get_FldPre FLD (); - Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; - get_FldPost FLD (). - -Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup (PackField FIELD_SIMPL_EQ) [] t; - [ try exact I - | clear H;intro H]. - - -Tactic Notation (at level 0) - "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; - [ try exact I - |clear H;intro H]. - -(* More generic tactics to build variants of field *) - -(* This tactic reifies c and pass to F: - - the FLD structure gathering all info in the field DB - - the atom list - - the expression (FExpr) - *) -Ltac gen_with_field F c := - let MetaExpr FLD _ rl := - let R := get_FldCarrier FLD in - let mkFFV := get_FFV FLD in - let mkFE := get_Meta FLD in - let csr := - match rl with - | List.cons ?r _ => r - | _ => fail 1 "anomaly: ill-formed list" - end in - let fv := mkFFV csr (@List.nil R) in - let expr := mkFE csr fv in - F FLD fv expr in - field_lookup (PackField MetaExpr) [] (c=c). - - -(* pushes the equation expr = ope(expr) in the goal, and - discharge it with field *) -Ltac prove_field_eqn ope FLD fv expr := - let res := ope expr in - let expr' := fresh "input_expr" in - pose (expr' := expr); - let res' := fresh "result" in - pose (res' := res); - let lemma := get_L1 FLD in - let lemma := - constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in - let ty := type of lemma in - let lhs := match ty with - forall _, ?lhs=_ -> _ => lhs - end in - let rhs := match ty with - forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs - end in - let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in - let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in - compute_assertion lhs_eq lhs' lhs; - compute_assertion rhs_eq rhs' rhs; - let H := fresh "fld_eqn" in - refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _)); - (* main goal *) - [intro H;protect_fv "field" in H; revert H - (* ring-nf(lhs') = ring-nf(rhs') *) - | vm_compute; reflexivity || fail "field cannot prove this equality" - (* denominator condition *) - | simpl_PCond FLD]; - clear lhs_eq rhs_eq; subst lhs' rhs'. - -Ltac prove_with_field ope c := - gen_with_field ltac:(prove_field_eqn ope) c. - -(* Prove an equation x=ope(x) and rewrite with it *) -Ltac prove_rw ope x := - prove_with_field ope x; - [ let H := fresh "Heq_maple" in - intro H; rewrite H; clear H - |..]. - -(* Apply ope (FExpr->FExpr) on an expression *) -Ltac reduce_field_expr ope kont FLD fv expr := - let evfun := get_FEeval FLD in - let res := ope expr in - let c := (eval simpl_field_expr in (evfun fv res)) in - kont c. - -(* Hack to let a Ltac return a term in the context of a primitive tactic *) -Ltac return_term x := generalize (eq_refl x). -Ltac get_term := - match goal with - | |- ?x = _ -> _ => x - end. - -(* Turn an operation on field expressions (FExpr) into a reduction - on terms (in the field carrier). Because of field_lookup, - the tactic cannot return a term directly, so it is returned - via the conclusion of the goal (return_term). *) -Ltac reduce_field_ope ope c := - gen_with_field ltac:(reduce_field_expr ope return_term) c. - - -(* Adding a new field *) - -Ltac ring_of_field f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) - end. - -Ltac coerce_to_almost_field set ext f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => f - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) - end. - -Ltac field_elements set ext fspec pspec sspec dspec rk := - let afth := coerce_to_almost_field set ext fspec in - let rspec := ring_of_field fspec in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). - -Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := - let get_lemma := - match pspec with None => fun x y => x | _ => fun x y => y end in - let simpl_eq_lemma := get_lemma - Field_simplify_eq_correct Field_simplify_eq_pow_correct in - let simpl_eq_in_lemma := get_lemma - Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in - let rw_lemma := get_lemma - Field_rw_correct Field_rw_pow_correct in - field_elements set ext fspec pspec sspec dspec rk - ltac:(fun afth ext_r morph p_spec s_spec d_spec => - match morph with - | _ => - let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in - match p_spec with - | mkhypo ?pp_spec => - let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in - match s_spec with - | mkhypo ?ss_spec => - match d_spec with - | mkhypo ?dd_spec => - let field_ok := constr:(field_ok2 _ dd_spec) in - let mk_lemma lemma := - constr:(lemma _ _ _ _ _ _ _ _ _ _ - set ext_r inv_m afth - _ _ _ _ _ _ _ _ _ morph - _ _ _ pp_spec _ ss_spec _ dd_spec) in - let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in - let field_simpl_ok := mk_lemma rw_lemma in - let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in - let cond1_ok := - constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in - let cond2_ok := - constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in - (fun f => - f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in - cond1_ok cond2_ok) - | _ => fail 4 "field: bad coefficient division specification" - end - | _ => fail 3 "field: bad sign specification" - end - | _ => fail 2 "field: bad power specification" - end - | _ => fail 1 "field internal error : field_lemmas, please report" - end). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v deleted file mode 100644 index 3736bc47a5..0000000000 --- a/plugins/setoid_ring/Field_theory.v +++ /dev/null @@ -1,1819 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Ring. -Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms. -Require Import ZArith_base. -Set Implicit Arguments. -(* Set Universe Polymorphism. *) - -Section MakeFieldPol. - -(* Field elements : R *) - -Variable R:Type. -Declare Scope R_scope. -Bind Scope R_scope with R. -Delimit Scope R_scope with ring. -Local Open Scope R_scope. - -Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). -Variable (rdiv : R->R->R) (rinv : R->R). -Variable req : R -> R -> Prop. - -Notation "0" := rO : R_scope. -Notation "1" := rI : R_scope. -Infix "+" := radd : R_scope. -Infix "-" := rsub : R_scope. -Infix "*" := rmul : R_scope. -Infix "/" := rdiv : R_scope. -Notation "- x" := (ropp x) : R_scope. -Notation "/ x" := (rinv x) : R_scope. -Infix "==" := req (at level 70, no associativity) : R_scope. - -(* Equality properties *) -Variable Rsth : Equivalence req. -Variable Reqe : ring_eq_ext radd rmul ropp req. -Variable SRinv_ext : forall p q, p == q -> / p == / q. - -(* Field properties *) -Record almost_field_theory : Prop := mk_afield { - AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; - AF_1_neq_0 : ~ 1 == 0; - AFdiv_def : forall p q, p / q == p * / q; - AFinv_l : forall p, ~ p == 0 -> / p * p == 1 -}. - -Section AlmostField. - -Variable AFth : almost_field_theory. -Let ARth := (AF_AR AFth). -Let rI_neq_rO := (AF_1_neq_0 AFth). -Let rdiv_def := (AFdiv_def AFth). -Let rinv_l := (AFinv_l AFth). - -Add Morphism radd with signature (req ==> req ==> req) as radd_ext. -Proof. exact (Radd_ext Reqe). Qed. -Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. -Proof. exact (Rmul_ext Reqe). Qed. -Add Morphism ropp with signature (req ==> req) as ropp_ext. -Proof. exact (Ropp_ext Reqe). Qed. -Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. -Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. -Add Morphism rinv with signature (req ==> req) as rinv_ext. -Proof. exact SRinv_ext. Qed. - -Let eq_trans := Setoid.Seq_trans _ _ Rsth. -Let eq_sym := Setoid.Seq_sym _ _ Rsth. -Let eq_refl := Setoid.Seq_refl _ _ Rsth. - -Let radd_0_l := ARadd_0_l ARth. -Let radd_comm := ARadd_comm ARth. -Let radd_assoc := ARadd_assoc ARth. -Let rmul_1_l := ARmul_1_l ARth. -Let rmul_0_l := ARmul_0_l ARth. -Let rmul_comm := ARmul_comm ARth. -Let rmul_assoc := ARmul_assoc ARth. -Let rdistr_l := ARdistr_l ARth. -Let ropp_mul_l := ARopp_mul_l ARth. -Let ropp_add := ARopp_add ARth. -Let rsub_def := ARsub_def ARth. - -Let radd_0_r := ARadd_0_r Rsth ARth. -Let rmul_0_r := ARmul_0_r Rsth ARth. -Let rmul_1_r := ARmul_1_r Rsth ARth. -Let ropp_0 := ARopp_zero Rsth Reqe ARth. -Let rdistr_r := ARdistr_r Rsth Reqe ARth. - -(* Coefficients : C *) - -Variable C: Type. -Declare Scope C_scope. -Bind Scope C_scope with C. -Delimit Scope C_scope with coef. - -Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). -Variable ceqb : C->C->bool. -Variable phi : C -> R. - -Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - -Notation "0" := cO : C_scope. -Notation "1" := cI : C_scope. -Infix "+" := cadd : C_scope. -Infix "-" := csub : C_scope. -Infix "*" := cmul : C_scope. -Notation "- x" := (copp x) : C_scope. -Infix "=?" := ceqb : C_scope. -Notation "[ x ]" := (phi x) (at level 0). - -Let phi_0 := (morph0 CRmorph). -Let phi_1 := (morph1 CRmorph). - -Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. -Proof. -generalize ((morph_eq CRmorph) c c'). -destruct (c =? c')%coef; auto. -Qed. - -(* Power coefficients : Cpow *) - -Variable Cpow : Type. -Variable Cp_phi : N -> Cpow. -Variable rpow : R -> Cpow -> R. -Variable pow_th : power_theory rI rmul req Cp_phi rpow. -(* sign function *) -Variable get_sign : C -> option C. -Variable get_sign_spec : sign_theory copp ceqb get_sign. - -Variable cdiv:C -> C -> C*C. -Variable cdiv_th : div_theory req cadd cmul phi cdiv. - -Let rpow_pow := (rpow_pow_N pow_th). - -(* Polynomial expressions : (PExpr C) *) - -Declare Scope PE_scope. -Bind Scope PE_scope with PExpr. -Delimit Scope PE_scope with poly. - -Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow). -Notation "P @ l" := (NPEeval l P) (at level 10, no associativity). - -Arguments PEc _ _%coef. - -Notation "0" := (PEc 0) : PE_scope. -Notation "1" := (PEc 1) : PE_scope. -Infix "+" := PEadd : PE_scope. -Infix "-" := PEsub : PE_scope. -Infix "*" := PEmul : PE_scope. -Notation "- e" := (PEopp e) : PE_scope. -Infix "^" := PEpow : PE_scope. - -Definition NPEequiv e e' := forall l, e@l == e'@l. -Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope. - -Instance NPEequiv_eq : Equivalence NPEequiv. -Proof. - split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity]; - eauto. -Qed. - -Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval. -Proof. - intros l l' <- e e' He. now rewrite (He l). -Qed. - -Notation Nnorm := - (norm_subst cO cI cadd cmul csub copp ceqb cdiv). -Notation NPphi_dev := - (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). -Notation NPphi_pow := - (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). - -(* add abstract semi-ring to help with some proofs *) -Add Ring Rring : (ARth_SRth ARth). - -(* additional ring properties *) - -Lemma rsub_0_l r : 0 - r == - r. -Proof. -rewrite rsub_def; ring. -Qed. - -Lemma rsub_0_r r : r - 0 == r. -Proof. -rewrite rsub_def, ropp_0; ring. -Qed. - -(*************************************************************************** - - Properties of division - - ***************************************************************************) - -Theorem rdiv_simpl p q : ~ q == 0 -> q * (p / q) == p. -Proof. -intros. -rewrite rdiv_def. -transitivity (/ q * q * p); [ ring | ]. -now rewrite rinv_l. -Qed. - -Instance rdiv_ext: Proper (req ==> req ==> req) rdiv. -Proof. -intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq. -Qed. - -Lemma rmul_reg_l p q1 q2 : - ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. -Proof. -intros H EQ. -assert (H' : p * (q1 / p) == p * (q2 / p)). -{ now rewrite !rdiv_def, !rmul_assoc, EQ. } -now rewrite !rdiv_simpl in H'. -Qed. - -Theorem field_is_integral_domain r1 r2 : - ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. -Proof. -intros H1 H2. contradict H2. -transitivity (/r1 * r1 * r2). -- now rewrite rinv_l. -- now rewrite <- rmul_assoc, H2. -Qed. - -Theorem ropp_neq_0 r : - ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. -Proof. -intros. -setoid_replace (- r) with (- (1) * r). -- apply field_is_integral_domain; trivial. -- now rewrite <- ropp_mul_l, rmul_1_l. -Qed. - -Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1. -Proof. -intros. rewrite rdiv_def, rmul_comm. now apply rinv_l. -Qed. - -Theorem rdiv1 r : r == r / 1. -Proof. -transitivity (1 * (r / 1)). -- symmetry; apply rdiv_simpl. apply rI_neq_rO. -- apply rmul_1_l. -Qed. - -Theorem rdiv2 a b c d : - ~ b == 0 -> - ~ d == 0 -> - a / b + c / d == (a * d + c * b) / (b * d). -Proof. -intros H H0. -assert (~ b * d == 0) by now apply field_is_integral_domain. -apply rmul_reg_l with (b * d); trivial. -rewrite rdiv_simpl; trivial. -rewrite rdistr_r. -apply radd_ext. -- now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl. -- now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl. -Qed. - - -Theorem rdiv2b a b c d e : - ~ (b*e) == 0 -> - ~ (d*e) == 0 -> - a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)). -Proof. -intros H H0. -assert (~ b == 0) by (contradict H; rewrite H; ring). -assert (~ e == 0) by (contradict H; rewrite H; ring). -assert (~ d == 0) by (contradict H0; rewrite H0; ring). -assert (~ b * (d * e) == 0) - by (repeat apply field_is_integral_domain; trivial). -apply rmul_reg_l with (b * (d * e)); trivial. -rewrite rdiv_simpl; trivial. -rewrite rdistr_r. -apply radd_ext. -- transitivity ((b * e) * (a / (b * e)) * d); - [ ring | now rewrite rdiv_simpl ]. -- transitivity ((d * e) * (c / (d * e)) * b); - [ ring | now rewrite rdiv_simpl ]. -Qed. - -Theorem rdiv5 a b : - (a / b) == - a / b. -Proof. -now rewrite !rdiv_def, ropp_mul_l. -Qed. - -Theorem rdiv3b a b c d e : - ~ (b * e) == 0 -> - ~ (d * e) == 0 -> - a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)). -Proof. -intros H H0. -rewrite !rsub_def, rdiv5, ropp_mul_l. -now apply rdiv2b. -Qed. - -Theorem rdiv6 a b : - ~ a == 0 -> ~ b == 0 -> / (a / b) == b / a. -Proof. -intros H H0. -assert (Hk : ~ a / b == 0). -{ contradict H. - transitivity (b * (a / b)). - - now rewrite rdiv_simpl. - - rewrite H. apply rmul_0_r. } -apply rmul_reg_l with (a / b); trivial. -rewrite (rmul_comm (a / b)), rinv_l; trivial. -rewrite !rdiv_def. -transitivity (/ a * a * (/ b * b)); [ | ring ]. -now rewrite !rinv_l, rmul_1_l. -Qed. - -Theorem rdiv4 a b c d : - ~ b == 0 -> - ~ d == 0 -> - (a / b) * (c / d) == (a * c) / (b * d). -Proof. -intros H H0. -assert (~ b * d == 0) by now apply field_is_integral_domain. -apply rmul_reg_l with (b * d); trivial. -rewrite rdiv_simpl; trivial. -transitivity (b * (a / b) * (d * (c / d))); [ ring | ]. -rewrite !rdiv_simpl; trivial. -Qed. - -Theorem rdiv4b a b c d e f : - ~ b * e == 0 -> - ~ d * f == 0 -> - ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d). -Proof. -intros H H0. -assert (~ b == 0) by (contradict H; rewrite H; ring). -assert (~ e == 0) by (contradict H; rewrite H; ring). -assert (~ d == 0) by (contradict H0; rewrite H0; ring). -assert (~ f == 0) by (contradict H0; rewrite H0; ring). -assert (~ b*d == 0) by now apply field_is_integral_domain. -assert (~ e*f == 0) by now apply field_is_integral_domain. -rewrite rdiv4; trivial. -transitivity ((e * f) * (a * c) / ((e * f) * (b * d))). -- apply rdiv_ext; ring. -- rewrite <- rdiv4, rdiv_r_r; trivial. -Qed. - -Theorem rdiv7 a b c d : - ~ b == 0 -> - ~ c == 0 -> - ~ d == 0 -> - (a / b) / (c / d) == (a * d) / (b * c). -Proof. -intros. -rewrite (rdiv_def (a / b)). -rewrite rdiv6; trivial. -apply rdiv4; trivial. -Qed. - -Theorem rdiv7b a b c d e f : - ~ b * f == 0 -> - ~ c * e == 0 -> - ~ d * f == 0 -> - ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c). -Proof. -intros Hbf Hce Hdf. -assert (~ c==0) by (contradict Hce; rewrite Hce; ring). -assert (~ e==0) by (contradict Hce; rewrite Hce; ring). -assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring). -assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring). -assert (~ b*c==0) by now apply field_is_integral_domain. -assert (~ e*f==0) by now apply field_is_integral_domain. -rewrite rdiv7; trivial. -transitivity ((e * f) * (a * d) / ((e * f) * (b * c))). -- apply rdiv_ext; ring. -- now rewrite <- rdiv4, rdiv_r_r. -Qed. - -Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0. -Proof. -intros H H0. apply rI_neq_rO. -rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r. -Qed. - -Theorem rdiv8 a b : ~ b == 0 -> a == 0 -> a / b == 0. -Proof. -intros H H0. -now rewrite rdiv_def, H0, rmul_0_l. -Qed. - -Theorem cross_product_eq a b c d : - ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d. -Proof. -intros. -transitivity (a / b * (d / d)). -- now rewrite rdiv_r_r, rmul_1_r. -- now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r. -Qed. - -(* Results about [pow_pos] and [pow_N] *) - -Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul). -Proof. -intros x y H p p' <-. -induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H. -Qed. - -Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul). -Proof. -intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext. -Qed. - -Lemma pow_pos_0 p : pow_pos rmul 0 p == 0. -Proof. -induction p;simpl;trivial; now rewrite !IHp. -Qed. - -Lemma pow_pos_1 p : pow_pos rmul 1 p == 1. -Proof. -induction p;simpl;trivial; ring [IHp]. -Qed. - -Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. -Proof. -induction p;simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. -Qed. - -Lemma pow_pos_mul_l x y p : - pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. -Proof. -induction p;simpl;trivial; ring [IHp]. -Qed. - -Lemma pow_pos_add_r x p1 p2 : - pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2. -Proof. - exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2). -Qed. - -Lemma pow_pos_mul_r x p1 p2 : - pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2. -Proof. -induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r; - simpl; trivial; ring [IHp1]. -Qed. - -Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0. -Proof. - intros Hx. induction p;simpl;trivial; - repeat (apply field_is_integral_domain; trivial). -Qed. - -Lemma pow_pos_div a b p : ~ b == 0 -> - pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p. -Proof. - intros. - induction p; simpl; trivial. - - rewrite IHp. - assert (nz := pow_pos_nz p H). - rewrite !rdiv4; trivial. - apply field_is_integral_domain; trivial. - - rewrite IHp. - assert (nz := pow_pos_nz p H). - rewrite !rdiv4; trivial. -Qed. - -(* === is a morphism *) - -Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C). -Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed. -Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C). -Proof. intros ? ? E l. simpl. now rewrite E. Qed. -Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C). -Proof. - intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial. -Qed. - -Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly. -Proof. - intros l. simpl. rewrite phi_1. apply rmul_1_l. -Qed. - -Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly. -Proof. - intros l. simpl. rewrite phi_1. apply rmul_1_r. -Qed. - -Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly. -Proof. - intros l. simpl. now rewrite !rpow_pow. -Qed. - -Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly. -Proof. - intros l. simpl. now rewrite !rpow_pow. -Qed. - -Lemma PEpow_1_l n : (1 ^ n === 1)%poly. -Proof. - intros l. simpl. rewrite rpow_pow. destruct n; simpl. - - now rewrite phi_1. - - now rewrite phi_1, pow_pos_1. -Qed. - -Lemma PEpow_add_r (e : PExpr C) n n' : - (e ^ (n+n') === e ^ n * e ^ n')%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. - destruct n; simpl. - - rewrite rmul_1_l. trivial. - - destruct n'; simpl. - + rewrite rmul_1_r. trivial. - + apply pow_pos_add_r. -Qed. - -Lemma PEpow_mul_l (e e' : PExpr C) n : - ((e * e') ^ n === e ^ n * e' ^ n)%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial. - - symmetry; apply rmul_1_l. - - apply pow_pos_mul_l. -Qed. - -Lemma PEpow_mul_r (e : PExpr C) n n' : - (e ^ (n * n') === (e ^ n) ^ n')%poly. -Proof. - intros l. simpl. rewrite !rpow_pow. - destruct n, n'; simpl; trivial. - - now rewrite pow_pos_1. - - apply pow_pos_mul_r. -Qed. - -Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0. -Proof. - intros. simpl. rewrite rpow_pow. destruct n; simpl. - - apply rI_neq_rO. - - now apply pow_pos_nz. -Qed. - - -(*************************************************************************** - - Some equality test - - ***************************************************************************) - -Local Notation "a &&& b" := (if a then b else false) - (at level 40, left associativity). - -(* equality test *) -Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := - match e, e' with - | PEc c, PEc c' => ceqb c c' - | PEX _ p, PEX _ p' => Pos.eqb p p' - | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | - e, - e' => PExpr_eq e e' - | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e' - | _, _ => false - end%poly. - -Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true. -Proof. - destruct a, b; split; trivial. -Qed. - -Theorem PExpr_eq_semi_ok e e' : - PExpr_eq e e' = true -> (e === e')%poly. -Proof. -revert e'; induction e; destruct e'; simpl; try discriminate. -- intros H l. now apply (morph_eq CRmorph). -- case Pos.eqb_spec; intros; now subst. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. -- intros H. now rewrite IHe. -- intros H. destruct (if_true _ _ H). - apply N.eqb_eq in H0. now rewrite IHe, H0. -Qed. - -Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e'). -Proof. - assert (H := PExpr_eq_semi_ok e e'). - destruct PExpr_eq; constructor; intros; trivial. now apply H. -Qed. - -(** Smart constructors for polynomial expression, - with reduction of constants *) - -Definition NPEadd e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 + c2) - | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 + e2 - (* Peut t'on factoriser ici ??? *) - | _, _ => (e1 + e2) - end%poly. -Infix "++" := NPEadd (at level 60, right associativity). - -Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly. -Proof. -intros l. -destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec); -try intro H; try rewrite H; simpl; -try apply eq_refl; try (ring [phi_0]). -apply (morph_add CRmorph). -Qed. - -Definition NPEsub e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 - c2) - | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 - e2 - (* Peut-on factoriser ici *) - | _, _ => e1 - e2 - end%poly. -Infix "--" := NPEsub (at level 50, left associativity). - -Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly. -Proof. -intros l. -destruct e1, e2; simpl; try reflexivity; try case ceqb_spec; - try intro H; try rewrite H; simpl; - try rewrite phi_0; try reflexivity; - try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). -apply (morph_sub CRmorph). -Qed. - -Definition NPEopp e1 := - match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly. - -Theorem NPEopp_ok e : (NPEopp e === -e)%poly. -Proof. -intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph). -Qed. - -Definition NPEpow x n := - match n with - | N0 => 1 - | Npos p => - if (p =? 1)%positive then x else - match x with - | PEc c => - if (c =? 1)%coef then 1 - else if (c =? 0)%coef then 0 - else PEc (pow_pos cmul c p) - | _ => x ^ n - end - end%poly. -Infix "^^" := NPEpow (at level 35, right associativity). - -Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly. -Proof. - intros l. unfold NPEpow; destruct n. - - simpl; now rewrite rpow_pow. - - case Pos.eqb_spec; [intro; subst | intros _]. - + simpl. now rewrite rpow_pow. - + destruct e;simpl;trivial. - repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl. - * now rewrite phi_1, pow_pos_1. - * now rewrite phi_0, pow_pos_0. - * now rewrite pow_pos_cst. -Qed. - -Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := - match x, y with - | PEc c1, PEc c2 => PEc (c1 * c2) - | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y - | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y - | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y - | _, _ => x * y - end%poly. -Infix "**" := NPEmul (at level 40, left associativity). - -Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. -Proof. -intros l. -revert e2; induction e1;destruct e2; simpl;try reflexivity; - repeat (case ceqb_spec; intro H; try rewrite H; clear H); - simpl; try reflexivity; try ring [phi_0 phi_1]. - apply (morph_mul CRmorph). -case N.eqb_spec; [intros <- | reflexivity]. -rewrite NPEpow_ok. simpl. -rewrite !rpow_pow. rewrite IHe1. -destruct n; simpl; [ ring | apply pow_pos_mul_l ]. -Qed. - -(* simplification *) -Fixpoint PEsimp (e : PExpr C) : PExpr C := - match e with - | e1 + e2 => (PEsimp e1) ++ (PEsimp e2) - | e1 * e2 => (PEsimp e1) ** (PEsimp e2) - | e1 - e2 => (PEsimp e1) -- (PEsimp e2) - | - e1 => NPEopp (PEsimp e1) - | e1 ^ n1 => (PEsimp e1) ^^ n1 - | _ => e - end%poly. - -Theorem PEsimp_ok e : (PEsimp e === e)%poly. -Proof. -induction e; simpl. -- reflexivity. -- reflexivity. -- intro l; trivial. -- intro l; trivial. -- rewrite NPEadd_ok. now f_equiv. -- rewrite NPEsub_ok. now f_equiv. -- rewrite NPEmul_ok. now f_equiv. -- rewrite NPEopp_ok. now f_equiv. -- rewrite NPEpow_ok. now f_equiv. -Qed. - - -(**************************************************************************** - - Datastructure - - ***************************************************************************) - -(* The input: syntax of a field expression *) - -Inductive FExpr : Type := - | FEO : FExpr - | FEI : FExpr - | FEc: C -> FExpr - | FEX: positive -> FExpr - | FEadd: FExpr -> FExpr -> FExpr - | FEsub: FExpr -> FExpr -> FExpr - | FEmul: FExpr -> FExpr -> FExpr - | FEopp: FExpr -> FExpr - | FEinv: FExpr -> FExpr - | FEdiv: FExpr -> FExpr -> FExpr - | FEpow: FExpr -> N -> FExpr . - -Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := - match pe with - | FEO => rO - | FEI => rI - | FEc c => phi c - | FEX x => BinList.nth 0 x l - | FEadd x y => FEeval l x + FEeval l y - | FEsub x y => FEeval l x - FEeval l y - | FEmul x y => FEeval l x * FEeval l y - | FEopp x => - FEeval l x - | FEinv x => / FEeval l x - | FEdiv x y => FEeval l x / FEeval l y - | FEpow x n => rpow (FEeval l x) (Cp_phi n) - end. - -Strategy expand [FEeval]. - -(* The result of the normalisation *) - -Record linear : Type := mk_linear { - num : PExpr C; - denum : PExpr C; - condition : list (PExpr C) }. - -(*************************************************************************** - - Semantics and properties of side condition - - ***************************************************************************) - -Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := - match le with - | nil => True - | e1 :: nil => ~ req (e1 @ l) rO - | e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1 - end. - -Theorem PCond_cons l a l1 : - PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1. -Proof. -destruct l1. -- simpl. split; [split|destruct 1]; trivial. -- reflexivity. -Qed. - -Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) -> ~ a @ l == 0. -Proof. -rewrite PCond_cons. now destruct 1. -Qed. - -Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) -> PCond l l1. -Proof. -rewrite PCond_cons. now destruct 1. -Qed. - -Theorem PCond_app l l1 l2 : - PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2. -Proof. -induction l1. -- simpl. split; [split|destruct 1]; trivial. -- simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. -Qed. - - -(* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons 0%poly nil. - -Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. -Proof. -unfold absurd_PCond; simpl. -red; intros. -apply H. -apply phi_0. -Qed. - -(*************************************************************************** - - Normalisation - - ***************************************************************************) - -Definition default_isIn e1 p1 e2 p2 := - if PExpr_eq e1 e2 then - match Z.pos_sub p1 p2 with - | Zpos p => Some (Npos p, 1%poly) - | Z0 => Some (N0, 1%poly) - | Zneg p => Some (N0, e2 ^^ Npos p) - end - else None. - -Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := - match e2 with - | e3 * e4 => - match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2)) - | Some (Npos p, e5) => - match isIn e1 p e4 p2 with - | Some (n, e6) => Some (n, e5 ** e6) - | None => Some (Npos p, e5 ** (e4 ^^ Npos p2)) - end - | None => - match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5) - | None => None - end - end - | e3 ^ N0 => None - | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2) - | _ => default_isIn e1 p1 e2 p2 - end%poly. - - Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. - Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - - Lemma Z_pos_sub_gt p q : (p > q)%positive -> - Z.pos_sub p q = Zpos (p - q). - Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. - - Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. - - Lemma default_isIn_ok e1 e2 p1 p2 : - match default_isIn e1 p1 e2 p2 with - | Some(n, e3) => - let n' := ZtoN (Zpos p1 - NtoZ n) in - (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly - /\ (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. - unfold default_isIn. - case PExpr_eq_spec; trivial. intros EQ. - rewrite Z.pos_sub_spec. - case Pos.compare_spec;intros H; split; try reflexivity. - - simpl. now rewrite PE_1_r, H, EQ. - - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv. - simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add. - - simpl. rewrite PE_1_r, EQ. f_equiv. - rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv. - rewrite Pos.sub_sub_distr, Pos.add_comm; trivial. - rewrite Pos.add_sub; trivial. - apply Pos.sub_decr; trivial. - - simpl. now apply Z.lt_gt, Pos.sub_decr. -Qed. - -Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l. -Ltac npe_ring := intro l; simpl; ring. - -Theorem isIn_ok e1 p1 e2 p2 : - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - let n' := ZtoN (Zpos p1 - NtoZ n) in - (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly - /\ (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. -Opaque NPEpow. -revert p1 p2. -induction e2; intros p1 p2; - try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. -- specialize (IHe2_1 p1 p2). - destruct isIn as [([|p],e)|]. - + split; [|reflexivity]. - clear IHe2_2. - destruct IHe2_1 as (IH,_). - npe_simpl. rewrite IH. npe_ring. - + specialize (IHe2_2 p p2). - destruct isIn as [([|p'],e')|]. - * destruct IHe2_1 as (IH1,GT1). - destruct IHe2_2 as (IH2,GT2). - split; [|simpl; apply Zgt_trans with (Z.pos p); trivial]. - npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. - replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N. - rewrite PEpow_add_r; npe_ring. - { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. trivial. - now apply Pos.gt_lt. } - * destruct IHe2_1 as (IH1,GT1). - destruct IHe2_2 as (IH2,GT2). - assert (Z.pos p1 > Z.pos p')%Z by (now apply Zgt_trans with (Zpos p)). - split; [|simpl; trivial]. - npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl. - replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N. - rewrite PEpow_add_r; npe_ring. - { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial. - now apply Pos.gt_lt. - now apply Pos.gt_lt. } - * destruct IHe2_1 as (IH,GT). split; trivial. - npe_simpl. rewrite IH. npe_ring. - + specialize (IHe2_2 p1 p2). - destruct isIn as [(n,e)|]; trivial. - destruct IHe2_2 as (IH,GT). split; trivial. - set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. - npe_simpl. rewrite IH. npe_ring. -- destruct n; trivial. - specialize (IHe2 p1 (p * p2)%positive). - destruct isIn as [(n,e)|]; trivial. - destruct IHe2 as (IH,GT). split; trivial. - set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d. - now rewrite <- PEpow_mul_r. -Qed. - -Record rsplit : Type := mk_rsplit { - rsplit_left : PExpr C; - rsplit_common : PExpr C; - rsplit_right : PExpr C}. - -(* Stupid name clash *) -Notation left := rsplit_left. -Notation right := rsplit_right. -Notation common := rsplit_common. - -Fixpoint split_aux e1 p e2 {struct e1}: rsplit := - match e1 with - | e3 * e4 => - let r1 := split_aux e3 p e2 in - let r2 := split_aux e4 p (right r1) in - mk_rsplit (left r1 ** left r2) - (common r1 ** common r2) - (right r2) - | e3 ^ N0 => mk_rsplit 1 1 e2 - | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2 - | _ => - match isIn e1 p e2 1 with - | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 - | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 - | None => mk_rsplit (e1 ^^ Npos p) 1 e2 - end - end%poly. - -Lemma split_aux_ok1 e1 p e2 : - (let res := match isIn e1 p e2 1 with - | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 - | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 - | None => mk_rsplit (e1 ^^ Npos p) 1 e2 - end - in - e1 ^ Npos p === left res * common res - /\ e2 === right res * common res)%poly. -Proof. - Opaque NPEpow NPEmul. - intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). - destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. - - intros (H1,H2); split; npe_simpl. - + now rewrite PE_1_l. - + rewrite PEpow_1_r in H1. rewrite H1. npe_ring. - - intros (H1,H2); split; npe_simpl. - + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal. - rewrite Pos.add_comm, Pos.sub_add; trivial. - now apply Z.gt_lt in H2. - + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring. - - intros _; split; npe_simpl; now rewrite PE_1_r. -Qed. - -Theorem split_aux_ok: forall e1 p e2, - (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2) - /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly. -Proof. -induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl. -destruct (IHe1_1 k e2) as (H1,H2). -destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4). -clear IHe1_1 IHe1_2. -- npe_simpl; split. - * rewrite H1, H3. npe_ring. - * rewrite H2 at 1. rewrite H4 at 1. npe_ring. -- destruct n; simpl. - + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split. - + rewrite <- PEpow_mul_r. simpl. apply IHe1. -Qed. - -Definition split e1 e2 := split_aux e1 xH e2. - -Theorem split_ok_l e1 e2 : - (e1 === left (split e1 e2) * common (split e1 e2))%poly. -Proof. -destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r. -Qed. - -Theorem split_ok_r e1 e2 : - (e2 === right (split e1 e2) * common (split e1 e2))%poly. -Proof. -destruct (split_aux_ok e1 xH e2) as (_,H). trivial. -Qed. - -Lemma split_nz_l l e1 e2 : - ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0. -Proof. - intros H. contradict H. rewrite (split_ok_l e1 e2); simpl. - now rewrite H, rmul_0_l. -Qed. - -Lemma split_nz_r l e1 e2 : - ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0. -Proof. - intros H. contradict H. rewrite (split_ok_r e1 e2); simpl. - now rewrite H, rmul_0_l. -Qed. - -Fixpoint Fnorm (e : FExpr) : linear := - match e with - | FEO => mk_linear 0 1 nil - | FEI => mk_linear 1 1 nil - | FEc c => mk_linear (PEc c) 1 nil - | FEX x => mk_linear (PEX C x) 1 nil - | FEadd e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) ++ (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEsub e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) -- (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEmul e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (denum y) in - let s2 := split (num y) (denum x) in - mk_linear (left s1 ** left s2) - (right s2 ** right s1) - (condition x ++ condition y)%list - | FEopp e1 => - let x := Fnorm e1 in - mk_linear (NPEopp (num x)) (denum x) (condition x) - | FEinv e1 => - let x := Fnorm e1 in - mk_linear (denum x) (num x) (num x :: condition x) - | FEdiv e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (num y) in - let s2 := split (denum x) (denum y) in - mk_linear (left s1 ** right s2) - (left s2 ** right s1) - (num y :: condition x ++ condition y)%list - | FEpow e1 n => - let x := Fnorm e1 in - mk_linear ((num x)^^n) ((denum x)^^n) (condition x) - end. - -(* Example *) -(* -Eval compute - in (Fnorm - (FEdiv - (FEc cI) - (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). -*) - -Theorem Pcond_Fnorm l e : - PCond l (condition (Fnorm e)) -> ~ (denum (Fnorm e))@l == 0. -Proof. -induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app; - simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok. -- simpl. rewrite phi_1; exact rI_neq_rO. -- simpl. rewrite phi_1; exact rI_neq_rO. -- simpl; intros. rewrite phi_1; exact rI_neq_rO. -- simpl; intros. rewrite phi_1; exact rI_neq_rO. -- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc1. - + apply IHe2, Hc2. -- rewrite <- split_ok_r. simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc1. - + apply IHe2, Hc2. -- simpl. apply field_is_integral_domain. - + apply split_nz_r, IHe1, Hc1. - + apply split_nz_r, IHe2, Hc2. -- now apply IHe. -- trivial. -- destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain. - + apply split_nz_l, IHe1, Hc2. - + apply split_nz_r, Hc1. -- rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc. -Qed. - - -(*************************************************************************** - - Main theorem - - ***************************************************************************) - -Ltac uneval := - repeat match goal with - | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l) - | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l) - end. - -Theorem Fnorm_FEeval_PEeval l fe: - PCond l (condition (Fnorm fe)) -> - FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l. -Proof. -induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl; - intros (Hc1,Hc2) || intros Hc; - try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1); - try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2); - try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *. - -- now rewrite phi_1, phi_0, rdiv_def. -- now rewrite phi_1; apply rdiv1. -- rewrite phi_1; apply rdiv1. -- rewrite phi_1; apply rdiv1. -- rewrite NPEadd_ok, !NPEmul_ok. simpl. - rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. - now f_equiv. - -- rewrite NPEsub_ok, !NPEmul_ok. simpl. - rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial. - now f_equiv. - -- rewrite !NPEmul_ok. simpl. - rewrite IHfe1, IHfe2. - rewrite (split_ok_l (num F1) (denum F2) l), - (split_ok_r (num F1) (denum F2) l), - (split_ok_l (num F2) (denum F1) l), - (split_ok_r (num F2) (denum F1) l) in *. - apply rdiv4b; trivial. - -- rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5. - -- rewrite (IHfe Hc2); apply rdiv6; trivial; - apply Pcond_Fnorm; trivial. - -- destruct Hc2 as (Hc2,Hc3). - rewrite !NPEmul_ok. simpl. - assert (U1 := split_ok_l (num F1) (num F2) l). - assert (U2 := split_ok_r (num F1) (num F2) l). - assert (U3 := split_ok_l (denum F1) (denum F2) l). - assert (U4 := split_ok_r (denum F1) (denum F2) l). - rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4. - simpl in U2, U3, U4. apply rdiv7b; - rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial. - -- rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc). - destruct n; simpl. - + apply rdiv1. - + apply pow_pos_div. apply Pcond_Fnorm; trivial. -Qed. - -Theorem Fnorm_crossproduct l fe1 fe2 : - let nfe1 := Fnorm fe1 in - let nfe2 := Fnorm fe2 in - (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2). -rewrite !Fnorm_FEeval_PEeval; trivial. -apply cross_product_eq; trivial; - apply Pcond_Fnorm; trivial. -Qed. - -(* Correctness lemmas of reflexive tactics *) -Notation Ninterp_PElist := - (interp_PElist rO rI radd rmul rsub ropp req phi Cp_phi rpow). -Notation Nmk_monpol_list := - (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). - -Theorem Fnorm_ok: - forall n l lpe fe, - Ninterp_PElist l lpe -> - Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> - PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. -Proof. -intros n l lpe fe Hlpe H H1. -rewrite (Fnorm_FEeval_PEeval l fe H1). -apply rdiv8. apply Pcond_Fnorm; trivial. -transitivity (0@l); trivial. -rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial. -change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)). -apply (Peq_ok Rsth Reqe CRmorph); trivial. -Qed. - -Notation ring_rw_correct := - (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). - -Notation ring_rw_pow_correct := - (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec). - -Notation ring_correct := - (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). - -(* simplify a field expression into a fraction *) -Definition display_linear l num den := - let lnum := NPphi_dev l num in - match den with - | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den - | _ => lnum / NPphi_dev l den - end. - -Definition display_pow_linear l num den := - let lnum := NPphi_pow l num in - match den with - | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den - | _ => lnum / NPphi_pow l den - end. - -Theorem Field_rw_correct n lpe l : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == - display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear. - destruct (Nnorm _ _ _) as [c | | ] eqn: HN; - try ( apply rdiv_ext; - eapply ring_rw_correct; eauto). - destruct (ceqb_spec c cI). - set (nnum := NPphi_dev _ _). - apply eq_trans with (nnum / NPphi_dev l (Pc c)). - apply rdiv_ext; - eapply ring_rw_correct; eauto. - rewrite Pphi_dev_ok; try eassumption. - now simpl; rewrite H0, phi_1, <- rdiv1. - apply rdiv_ext; - eapply ring_rw_correct; eauto. -Qed. - -Theorem Field_rw_pow_correct n lpe l : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == - display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear. - destruct (Nnorm _ _ _) as [c | | ] eqn: HN; - try ( apply rdiv_ext; - eapply ring_rw_pow_correct; eauto). - destruct (ceqb_spec c cI). - set (nnum := NPphi_pow _ _). - apply eq_trans with (nnum / NPphi_pow l (Pc c)). - apply rdiv_ext; - eapply ring_rw_pow_correct; eauto. - rewrite Pphi_pow_ok; try eassumption. - now simpl; rewrite H0, phi_1, <- rdiv1. - apply rdiv_ext; - eapply ring_rw_pow_correct; eauto. -Qed. - -Theorem Field_correct n l lpe fe1 fe2 : - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2)) - (Nnorm n lmp (num nfe2 * denum nfe1)) = true -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. -apply Fnorm_crossproduct; trivial. -eapply ring_correct; eauto. -Qed. - -(* simplify a field equation : generate the crossproduct and simplify - polynomials *) - -(** This allows rewriting modulo the simplification of PEeval on PMul *) -Declare Equivalent Keys PEeval rmul. - -Theorem Field_simplify_eq_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) == - NPphi_dev l (Nnorm n lmp (num nfe2 * left den)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. -apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. -simpl. -rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. -rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. -simpl. -rewrite !rmul_assoc. -apply rmul_ext; trivial. -rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), - (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). -rewrite Hlmp. -apply Hcrossprod. -Qed. - -Theorem Field_simplify_eq_pow_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) == - NPphi_pow l (Nnorm n lmp (num nfe2 * left den)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond. -apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial. -simpl. -rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3. -rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3. -simpl. -rewrite !rmul_assoc. -apply rmul_ext; trivial. -rewrite - (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl), - (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl). -rewrite Hlmp. -apply Hcrossprod. -Qed. - -Theorem Field_simplify_aux_ok l fe1 fe2 den : - FEeval l fe1 == FEeval l fe2 -> - split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den -> - PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) -> - (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l. -Proof. - rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl. - assert (Hc1' := Pcond_Fnorm _ _ Hc1). - assert (Hc2' := Pcond_Fnorm _ _ Hc2). - set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *. - set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *. - assert (~ (common den) @ l == 0). - { intro H. apply Hc1'. - rewrite (split_ok_l D1 D2 l). - rewrite Hden. simpl. ring [H]. } - apply (@rmul_reg_l ((common den) @ l)); trivial. - rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc. - change - (N1@l * (right den * common den) @ l == - N2@l * (left den * common den) @ l). - rewrite <- Hden, <- split_ok_l, <- split_ok_r. - apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. } - rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc. - rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial. - apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. } - rewrite !(rmul_comm (/ D1@l)), <- !rmul_assoc. - rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial. - rewrite (rmul_comm (/ D2@l)), <- rdiv_def. - unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial. -Qed. - -Theorem Field_simplify_eq_pow_in_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> - forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_pow l np1 == - NPphi_pow l np2. -Proof. - intros. subst nfe1 nfe2 lmp np1 np2. - rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). - simpl. apply Field_simplify_aux_ok; trivial. -Qed. - -Theorem Field_simplify_eq_in_correct : -forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (num nfe1 * right den) = np1 -> - forall np2, Nnorm n lmp (num nfe2 * left den) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_dev l np1 == NPphi_dev l np2. -Proof. - intros. subst nfe1 nfe2 lmp np1 np2. - rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). - apply Field_simplify_aux_ok; trivial. -Qed. - - -Section Fcons_impl. - -Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). - -Hypothesis PCond_fcons_inv : forall l a l1, - PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. - -Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - | nil => m - | cons a l1 => Fcons a (Fapp l1 m) - end. - -Lemma fcons_ok : forall l l1, - (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. -Proof. -intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1. -induction l1; simpl; intros. - trivial. - elim PCond_fcons_inv with (1 := H); intros. - destruct l1; trivial. split; trivial. apply IHl1; trivial. -Qed. - -End Fcons_impl. - -Section Fcons_simpl. - -(* Some general simpifications of the condition: eliminate duplicates, - split multiplications *) - -Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) - end. - -Theorem PFcons_fcons_inv: - forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -induction l1 as [|e l1]; simpl Fcons. -- simpl; now split. -- case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2); - repeat split; trivial. - + now rewrite H. - + now apply IHl1. - + now apply IHl1. -Qed. - -(* equality of normal forms rather than syntactic equality *) -Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => - if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l - else cons a (Fcons0 e l1) - end. - -Theorem PFcons0_fcons_inv: - forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -induction l1 as [|e l1]; simpl Fcons0. -- simpl; now split. -- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. - case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); - repeat split; trivial. - + now rewrite H. - + now apply IHl1. - + now apply IHl1. -Qed. - -(* split factorized denominators *) -Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) - | PEpow e1 _ => Fcons00 e1 l - | _ => Fcons0 e l - end. - -Theorem PFcons00_fcons_inv: - forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). -- intros p H p0 H0 l1 H1. - simpl in H1. - destruct (H _ H1) as (H2,H3). - destruct (H0 _ H3) as (H4,H5). split; trivial. - simpl. - apply field_is_integral_domain; trivial. -- intros. destruct (H _ H0). split; trivial. - apply PEpow_nz; trivial. -Qed. - -Definition Pcond_simpl_gen := - fcons_ok _ PFcons00_fcons_inv. - - -(* Specific case when the equality test of coefs is complete w.r.t. the - field equality: non-zero coefs can be eliminated, and opposite can - be simplified (if -1 <> 0) *) - -Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true. - -Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2). -Proof. -assert (H := morph_eq CRmorph c1 c2). -assert (H' := @ceqb_complete c1 c2). -destruct (ceqb c1 c2); constructor. -- now apply H. -- intro E. specialize (H' E). discriminate. -Qed. - -Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l - | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l - | PEc c => if (c =? 0)%coef then absurd_PCond else l - | _ => Fcons0 e l - end. - -Theorem PFcons1_fcons_inv: - forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). -- simpl; intros c l1. - case ceqb_spec'; intros H H0. - + elim (@absurd_PCond_bottom l H0). - + split; trivial. rewrite <- phi_0; trivial. -- intros p H p0 H0 l1 H1. simpl in H1. - destruct (H _ H1) as (H2,H3). - destruct (H0 _ H3) as (H4,H5). - split; trivial. simpl. apply field_is_integral_domain; trivial. -- simpl; intros p H l1. - case ceqb_spec'; intros H0 H1. - + elim (@absurd_PCond_bottom l H1). - + destruct (H _ H1). - split; trivial. - apply ropp_neq_0; trivial. - rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial. -- intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. -Qed. - -Definition Fcons2 e l := Fcons1 (PEsimp e) l. - -Theorem PFcons2_fcons_inv: - forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1. -Proof. -unfold Fcons2; intros l a l1 H; split; - case (PFcons1_fcons_inv l (PEsimp a) l1); trivial. -intros H1 H2 H3; case H1. -transitivity (a@l); trivial. -apply PEsimp_ok. -Qed. - -Definition Pcond_simpl_complete := - fcons_ok _ PFcons2_fcons_inv. - -End Fcons_simpl. - -End AlmostField. - -Section FieldAndSemiField. - - Record field_theory : Prop := mk_field { - F_R : ring_theory rO rI radd rmul rsub ropp req; - F_1_neq_0 : ~ 1 == 0; - Fdiv_def : forall p q, p / q == p * / q; - Finv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - - Definition F2AF f := - mk_afield - (Rth_ARth Rsth Reqe (F_R f)) (F_1_neq_0 f) (Fdiv_def f) (Finv_l f). - - Record semi_field_theory : Prop := mk_sfield { - SF_SR : semi_ring_theory rO rI radd rmul req; - SF_1_neq_0 : ~ 1 == 0; - SFdiv_def : forall p q, p / q == p * / q; - SFinv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - -End FieldAndSemiField. - -End MakeFieldPol. - - Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth - (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := - mk_afield _ _ - (SRth_ARth Rsth (SF_SR sf)) - (SF_1_neq_0 sf) - (SFdiv_def sf) - (SFinv_l sf). - - -Section Complete. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable (rdiv : R -> R -> R) (rinv : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). - Notation "x == y" := (req x y) (at level 70, no associativity). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid3. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext3. - Proof. exact (Ropp_ext Reqe). Qed. - -Section AlmostField. - - Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := (AF_AR AFth). - Let rI_neq_rO := (AF_1_neq_0 AFth). - Let rdiv_def := (AFdiv_def AFth). - Let rinv_l := (AFinv_l AFth). - -Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. - -Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Lemma add_inj_r p x y : - gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. -Proof. -elim p using Pos.peano_ind; simpl; intros. - apply S_inj; trivial. - apply H. - apply S_inj. - rewrite !(ARadd_assoc ARth). - rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial. -Qed. - -Lemma gen_phiPOS_inj x y : - gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> - x = y. -Proof. -rewrite <- !(same_gen Rsth Reqe ARth). -case (Pos.compare_spec x y). - intros. - trivial. - intros. - elim gen_phiPOS_not_0 with (y - x)%positive. - apply add_inj_r with x. - symmetry. - rewrite (ARadd_0_r Rsth ARth). - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). - now rewrite Pos.add_comm, Pos.sub_add. - intros. - elim gen_phiPOS_not_0 with (x - y)%positive. - apply add_inj_r with y. - rewrite (ARadd_0_r Rsth ARth). - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). - now rewrite Pos.add_comm, Pos.sub_add. -Qed. - - -Lemma gen_phiN_inj x y : - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - x = y. -Proof. -destruct x; destruct y; simpl; intros; trivial. - elim gen_phiPOS_not_0 with p. - symmetry . - rewrite (same_gen Rsth Reqe ARth); trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth); trivial. - rewrite gen_phiPOS_inj with (1 := H); trivial. -Qed. - -Lemma gen_phiN_complete x y : - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - N.eqb x y = true. -Proof. -intros. now apply N.eqb_eq, gen_phiN_inj. -Qed. - -End AlmostField. - -Section Field. - - Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := (F_R Fth). - Let rI_neq_rO := (F_1_neq_0 Fth). - Let rdiv_def := (Fdiv_def Fth). - Let rinv_l := (Finv_l Fth). - Let AFth := F2AF Rsth Reqe Fth. - Let ARth := Rth_ARth Rsth Reqe Rth. - -Lemma ring_S_inj x y : 1+x==1+y -> x==y. -Proof. -intros. -rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y). -rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1). -rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe). -Qed. - -Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Let gen_phiPOS_inject := - gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. - -Lemma gen_phiPOS_discr_sgn x y : - ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. -Proof. -red; intros. -apply gen_phiPOS_not_0 with (y + x)%positive. -rewrite (ARgen_phiPOS_add Rsth Reqe ARth). -transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). - apply (Radd_ext Reqe); trivial. - reflexivity. - rewrite (same_gen Rsth Reqe ARth). - rewrite (same_gen Rsth Reqe ARth). - trivial. - apply (Ropp_def Rth). -Qed. - -Lemma gen_phiZ_inj x y : - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - x = y. -Proof. -destruct x; destruct y; simpl; intros. - trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - symmetry ; trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite <- H. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - trivial. - rewrite gen_phiPOS_inject with (1 := H); trivial. - elim gen_phiPOS_discr_sgn with (1 := H). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite H. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_discr_sgn with p0 p. - symmetry ; trivial. - replace p0 with p; trivial. - apply gen_phiPOS_inject. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)). - rewrite H; trivial. - reflexivity. -Qed. - -Lemma gen_phiZ_complete x y : - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - Zeq_bool x y = true. -Proof. -intros. - replace y with x. - unfold Zeq_bool. - rewrite Z.compare_refl; trivial. - apply gen_phiZ_inj; trivial. -Qed. - -End Field. - -End Complete. - -Arguments FEO {C}. -Arguments FEI {C}. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v deleted file mode 100644 index dc096554c8..0000000000 --- a/plugins/setoid_ring/InitialRing.v +++ /dev/null @@ -1,894 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Zbool. -Require Import BinInt. -Require Import BinNat. -Require Import Setoid. -Require Import Ring_theory. -Require Import Ring_polynom. -Import List. - -Set Implicit Arguments. -(* Set Universe Polymorphism. *) - -Import RingSyntax. - -(* An object to return when an expression is not recognized as a constant *) -Definition NotConstant := false. - -(** Z is a ring and a setoid*) - -Lemma Zsth : Setoid_Theory Z (@eq Z). -Proof (Eqsth Z). - -Lemma Zeqe : ring_eq_ext Z.add Z.mul Z.opp (@eq Z). -Proof (Eq_ext Z.add Z.mul Z.opp). - -Lemma Zth : ring_theory Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (@eq Z). -Proof. - constructor. exact Z.add_0_l. exact Z.add_comm. exact Z.add_assoc. - exact Z.mul_1_l. exact Z.mul_comm. exact Z.mul_assoc. - exact Z.mul_add_distr_r. trivial. exact Z.sub_diag. -Qed. - -(** Two generic morphisms from Z to (abrbitrary) rings, *) -(**second one is more convenient for proofs but they are ext. equal*) -Section ZMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid3. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext3. - Proof. exact (Ropp_ext Reqe). Qed. - - Fixpoint gen_phiPOS1 (p:positive) : R := - match p with - | xH => 1 - | xO p => (1 + 1) * (gen_phiPOS1 p) - | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) - end. - - Fixpoint gen_phiPOS (p:positive) : R := - match p with - | xH => 1 - | xO xH => (1 + 1) - | xO p => (1 + 1) * (gen_phiPOS p) - | xI xH => 1 + (1 +1) - | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) - end. - - Definition gen_phiZ1 z := - match z with - | Zpos p => gen_phiPOS1 p - | Z0 => 0 - | Zneg p => -(gen_phiPOS1 p) - end. - - Definition gen_phiZ z := - match z with - | Zpos p => gen_phiPOS p - | Z0 => 0 - | Zneg p => -(gen_phiPOS p) - end. - Notation "[ x ]" := (gen_phiZ x). - - Definition get_signZ z := - match z with - | Zneg p => Some (Zpos p) - | _ => None - end. - - Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ. - Proof. - constructor. - destruct c;intros;try discriminate. - injection H as [= <-]. - simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. - Qed. - - - Section ALMOST_RING. - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext3. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. - Proof. - induction x;simpl. - rewrite IHx;destruct x;simpl;norm. - rewrite IHx;destruct x;simpl;norm. - rrefl. - Qed. - - Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). - Proof. - induction x;simpl;norm. - rewrite IHx;norm. - add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_add : forall x y, - gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). - Proof. - induction x;destruct y;simpl;norm. - rewrite Pos.add_carry_spec. - rewrite ARgen_phiPOS_Psucc. - rewrite IHx;norm. - add_push (gen_phiPOS1 y);add_push 1;rrefl. - rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. - rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. - add_push 1;rrefl. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_mult : - forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. - Proof. - induction x;intros;simpl;norm. - rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. - rewrite IHx;rrefl. - Qed. - - End ALMOST_RING. - - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - Let ARth := Rth_ARth Rsth Reqe Rth. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext4. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - -(*morphisms are extensionally equal*) - Lemma same_genZ : forall x, [x] == gen_phiZ1 x. - Proof. - destruct x;simpl; try rewrite (same_gen ARth);rrefl. - Qed. - - Lemma gen_Zeqb_ok : forall x y, - Zeq_bool x y = true -> [x] == [y]. - Proof. - intros x y H. - assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. - rewrite H1;rrefl. - Qed. - - Lemma gen_phiZ1_pos_sub : forall x y, - gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; simpl. - rewrite H. rewrite (Ropp_def Rth);rrefl. - rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - rewrite (Ropp_def Rth);norm. - rewrite <- (Pos.sub_add x y H) at 2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm. - Qed. - - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - destruct x, y; simpl; norm. - apply (ARgen_phiPOS_add ARth). - apply gen_phiZ1_pos_sub. - rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). - rewrite (ARgen_phiPOS_add ARth); norm. - Qed. - - Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genZ. - destruct x;destruct y;simpl;norm; - rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). - rewrite (Ropp_opp Rsth Reqe Rth);rrefl. - Qed. - - Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. - Proof. intros;subst;rrefl. Qed. - -(*proof that [.] satisfies morphism specifications*) - Lemma gen_phiZ_morph : - ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) - Z.add Z.mul Z.sub Z.opp Zeq_bool gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) - Z.add Z.mul Zeq_bool gen_phiZ). - apply mkRmorph;simpl;try rrefl. - apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. - apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). - Qed. - -End ZMORPHISM. - -(** N is a semi-ring and a setoid*) -Lemma Nsth : Setoid_Theory N (@eq N). -Proof (Eqsth N). - -Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N). -Proof (Eq_s_ext N.add N.mul). - -Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@eq N). -Proof. - constructor. exact N.add_0_l. exact N.add_comm. exact N.add_assoc. - exact N.mul_1_l. exact N.mul_0_l. exact N.mul_comm. exact N.mul_assoc. - exact N.mul_add_distr_r. -Qed. - -Definition Nsub := SRsub N.add. -Definition Nopp := (@SRopp N). - -Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N). -Proof (SReqe_Reqe Nseqe). - -Lemma Nath : - almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N). -Proof (SRth_ARth Nsth Nth). - -Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. -Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. - -(**Same as above : definition of two, extensionally equal, generic morphisms *) -(**from N to any semi-ring*) -Section NMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul: R->R->R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid4. - Ltac rrefl := gen_reflexivity Rsth. - Variable SReqe : sring_eq_ext radd rmul req. - Variable SRth : semi_ring_theory 0 1 radd rmul req. - Let ARth := SRth_ARth Rsth SRth. - Let Reqe := SReqe_Reqe SReqe. - Let ropp := (@SRopp R). - Let rsub := (@SRsub R radd). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Add Morphism radd with signature (req ==> req ==> req) as radd_ext4. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext4. - Proof. exact (Rmul_ext Reqe). Qed. - Ltac norm := gen_srewrite_sr Rsth Reqe ARth. - - Definition gen_phiN1 x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS1 1 radd rmul x - end. - - Definition gen_phiN x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS 1 radd rmul x - end. - Notation "[ x ]" := (gen_phiN x). - - Lemma same_genN : forall x, [x] == gen_phiN1 x. - Proof. - destruct x;simpl. reflexivity. - now rewrite (same_gen Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_add Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_mult Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. - Proof. exact gen_phiN_add. Qed. - -(*gen_phiN satisfies morphism specifications*) - Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req - 0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN. - Proof. - constructor; simpl; try reflexivity. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - intros x y EQ. apply N.eqb_eq in EQ. now subst. - Qed. - -End NMORPHISM. - -(* Words on N : initial structure for almost-rings. *) -Definition Nword := list N. -Definition NwO : Nword := nil. -Definition NwI : Nword := 1%N :: nil. - -Definition Nwcons n (w : Nword) : Nword := - match w, n with - | nil, 0%N => nil - | _, _ => n :: w - end. - -Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := - match w1, w2 with - | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' - | nil, _ => w2 - | _, nil => w1 - end. - -Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. - -Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). - -Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := - match w with - | m :: w' => (n*m)%N :: Nwscal n w' - | nil => nil - end. - -Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := - match w1 with - | 0%N::w1' => Nwopp (Nwmul w1' w2) - | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) - | nil => nil - end. -Fixpoint Nw_is0 (w : Nword) : bool := - match w with - | nil => true - | 0%N :: w' => Nw_is0 w' - | _ => false - end. - -Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := - match w1, w2 with - | n1::w1', n2::w2' => - if N.eqb n1 n2 then Nweq_bool w1' w2' else false - | nil, _ => Nw_is0 w2 - | _, nil => Nw_is0 w1 - end. - -Section NWORDMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_setoid5. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext5. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext5. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext5. - Proof. exact (Ropp_ext Reqe). Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext7. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Fixpoint gen_phiNword (w : Nword) : R := - match w with - | nil => 0 - | n :: nil => gen_phiN rO rI radd rmul n - | N0 :: w' => - gen_phiNword w' - | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' - end. - - Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. -Proof. -induction w; simpl; intros; auto. - reflexivity. - - destruct a. - destruct w. - reflexivity. - - rewrite IHw; trivial. - apply (ARopp_zero Rsth Reqe ARth). - - discriminate. -Qed. - - Lemma gen_phiNword_cons : forall w n, - gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -induction w. - destruct n; simpl; norm. - - intros. - destruct n; norm. -Qed. - - Lemma gen_phiNword_Nwcons : forall w n, - gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -destruct w; intros. - destruct n; norm. - - unfold Nwcons. - rewrite gen_phiNword_cons. - reflexivity. -Qed. - - Lemma gen_phiNword_ok : forall w1 w2, - Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. -induction w1; intros. - simpl. - rewrite (gen_phiNword0_ok _ H). - reflexivity. - - rewrite gen_phiNword_cons. - destruct w2. - simpl in H. - destruct a; try discriminate. - rewrite (gen_phiNword0_ok _ H). - norm. - - simpl in H. - rewrite gen_phiNword_cons. - case_eq (N.eqb a n); intros H0. - rewrite H0 in H. - apply N.eqb_eq in H0. rewrite <- H0. - rewrite (IHw1 _ H). - reflexivity. - - rewrite H0 in H; discriminate H. -Qed. - - -Lemma Nwadd_ok : forall x y, - gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. -induction x; intros. - simpl. - norm. - - destruct y. - simpl Nwadd; norm. - - simpl Nwadd. - repeat rewrite gen_phiNword_cons. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by - (destruct Reqe; constructor; trivial). - - rewrite IHx. - norm. - add_push (- gen_phiNword x); reflexivity. -Qed. - -Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. -simpl. -unfold Nwopp; simpl. -intros. -rewrite gen_phiNword_Nwcons; norm. -Qed. - -Lemma Nwscal_ok : forall n x, - gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. -induction x; intros. - norm. - - simpl Nwscal. - repeat rewrite gen_phiNword_cons. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) - by (destruct Reqe; constructor; trivial). - - rewrite IHx. - norm. -Qed. - -Lemma Nwmul_ok : forall x y, - gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. -induction x; intros. - norm. - - destruct a. - simpl Nwmul. - rewrite Nwopp_ok. - rewrite IHx. - rewrite gen_phiNword_cons. - norm. - - simpl Nwmul. - unfold Nwsub. - rewrite Nwadd_ok. - rewrite Nwscal_ok. - rewrite Nwopp_ok. - rewrite IHx. - rewrite gen_phiNword_cons. - norm. -Qed. - -(* Proof that [.] satisfies morphism specifications *) - Lemma gen_phiNword_morph : - ring_morph 0 1 radd rmul rsub ropp req - NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. -constructor. - reflexivity. - - reflexivity. - - exact Nwadd_ok. - - intros. - unfold Nwsub. - rewrite Nwadd_ok. - rewrite Nwopp_ok. - norm. - - exact Nwmul_ok. - - exact Nwopp_ok. - - exact gen_phiNword_ok. -Qed. - -End NWORDMORPHISM. - -Section GEN_DIV. - - Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) - (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) - (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) - (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) - (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - - (* Useful tactics *) - Add Parametric Relation : R req - reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) - symmetry proved by (@Equivalence_Symmetric _ _ Rsth) - transitivity proved by (@Equivalence_Transitive _ _ Rsth) - as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Definition triv_div x y := - if ceqb x y then (cI, cO) - else (cO, x). - - Ltac Esimpl :=repeat (progress ( - match goal with - | |- context [phi cO] => rewrite (morph0 morph) - | |- context [phi cI] => rewrite (morph1 morph) - | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) - | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) - | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) - | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) - end)). - - Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. - Proof. - constructor. - intros a b;unfold triv_div. - assert (X:= morph_eq morph a b);destruct (ceqb a b). - Esimpl. - rewrite X; trivial. - rsimpl. - Esimpl; rsimpl. -Qed. - - Variable zphi : Z -> R. - - Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. - Proof. - constructor. - intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. - rewrite Z.mul_comm; rsimpl. - Qed. - - Variable nphi : N -> R. - - Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. - constructor. - intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. - rewrite N.mul_comm; rsimpl. - Qed. - -End GEN_DIV. - - (* syntaxification of constants in an abstract ring: - the inverse of gen_phiPOS *) - Ltac inv_gen_phi_pos rI add mul t := - let rec inv_cst t := - match t with - rI => constr:(1%positive) - | (add rI rI) => constr:(2%positive) - | (add rI (add rI rI)) => constr:(3%positive) - | (mul (add rI rI) ?p) => (* 2p *) - match inv_cst p with - NotConstant => constr:(NotConstant) - | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *) - | ?p => constr:(xO p) - end - | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) - match inv_cst p with - NotConstant => constr:(NotConstant) - | 1%positive => constr:(NotConstant) - | ?p => constr:(xI p) - end - | _ => constr:(NotConstant) - end in - inv_cst t. - -(* The (partial) inverse of gen_phiNword *) - Ltac inv_gen_phiNword rO rI add mul opp t := - match t with - rO => constr:(NwO) - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Npos p::nil) - end - end. - - -(* The inverse of gen_phiN *) - Ltac inv_gen_phiN rO rI add mul t := - match t with - rO => constr:(0%N) - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Npos p) - end - end. - -(* The inverse of gen_phiZ *) - Ltac inv_gen_phiZ rO rI add mul opp t := - match t with - rO => constr:(0%Z) - | (opp ?p) => - match inv_gen_phi_pos rI add mul p with - NotConstant => constr:(NotConstant) - | ?p => constr:(Zneg p) - end - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:(NotConstant) - | ?p => constr:(Zpos p) - end - end. - -(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reified constant - instead of resorting to the constant propagation of the simplification - algorithm. *) -Ltac inv_gen_phi rO rI cO cI t := - match t with - | rO => cO - | rI => cI - end. - -(* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:(NotConstant). - -Ltac coerce_to_almost_ring set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) - | almost_ring_theory _ _ _ _ _ _ _ => rspec - | _ => fail 1 "not a valid ring theory" - end. - -Ltac coerce_to_ring_ext ext := - match type of ext with - | ring_eq_ext _ _ _ _ => ext - | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) - | _ => fail 1 "not a valid ring_eq_ext theory" - end. - -Ltac abstract_ring_morphism set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) - | almost_ring_theory _ _ _ _ _ _ _ => - constr:(gen_phiNword_morph set ext rspec) - | _ => fail 1 "bad ring structure" - end. - -Record hypo : Type := mkhypo { - hypo_type : Type; - hypo_proof : hypo_type - }. - -Ltac gen_ring_pow set arth pspec := - match pspec with - | None => - match type of arth with - | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => - constr:(mkhypo (@pow_N_th R rI rmul req set)) - | _ => fail 1 "gen_ring_pow" - end - | Some ?t => constr:(t) - end. - -Ltac gen_ring_sign morph sspec := - match sspec with - | None => - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(mkhypo (@get_sign_None_th C copp ceqb)) - | _ => fail 2 "ring anomaly : default_sign_spec" - end - | Some ?t => constr:(t) - end. - -Ltac default_div_spec set reqe arth morph := - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ztriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ntriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (triv_div_th set reqe arth morph)) - | _ => fail 1 "ring anomaly : default_sign_spec" - end. - -Ltac gen_ring_div set reqe arth morph dspec := - match dspec with - | None => default_div_spec set reqe arth morph - | Some ?t => constr:(t) - end. - -Ltac ring_elements set ext rspec pspec sspec dspec rk := - let arth := coerce_to_almost_ring set ext rspec in - let ext_r := coerce_to_ring_ext ext in - let morph := - match rk with - | Abstract => abstract_ring_morphism set ext rspec - | @Computational ?reqb_ok => - match type of arth with - | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => - constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) - | _ => fail 2 "ring anomaly" - end - | @Morphism ?m => - match type of m with - | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m - | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => - constr:(SRmorph_Rmorph set m) - | _ => fail 2 "ring anomaly" - end - | _ => fail 1 "ill-formed ring kind" - end in - let p_spec := gen_ring_pow set arth pspec in - let s_spec := gen_ring_sign morph sspec in - let d_spec := gen_ring_div set ext_r arth morph dspec in - fun f => f arth ext_r morph p_spec s_spec d_spec. - -(* Given a ring structure and the kind of morphism, - returns 2 lemmas (one for ring, and one for ring_simplify). *) - - Ltac ring_lemmas set ext rspec pspec sspec dspec rk := - let gen_lemma2 := - match pspec with - | None => constr:(ring_rw_correct) - | Some _ => constr:(ring_rw_pow_correct) - end in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec => - lazymatch type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - let gen_lemma2_0 := - constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth - C c0 c1 cadd cmul csub copp ceq_b phi morph) in - lazymatch p_spec with - | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => - let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in - lazymatch d_spec with - | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => - let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in - lazymatch s_spec with - | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => - let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in - let lemma1 := - constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in - fun f => f arth ext_r morph lemma1 lemma2 - | _ => fail "ring: bad sign specification" - end - | _ => fail "ring: bad coefficient division specification" - end - | _ => fail "ring: bad power specification" - end - | _ => fail "ring internal error: ring_lemmas, please report" - end). - -(* Tactic for constant *) -Ltac isnatcst t := - match t with - O => constr:(true) - | S ?p => isnatcst p - | _ => constr:(false) - end. - -Ltac isPcst t := - match t with - | xI ?p => isPcst p - | xO ?p => isPcst p - | xH => constr:(true) - (* nat -> positive *) - | Pos.of_succ_nat ?n => isnatcst n - | _ => constr:(false) - end. - -Ltac isNcst t := - match t with - N0 => constr:(true) - | Npos ?p => isPcst p - | _ => constr:(false) - end. - -Ltac isZcst t := - match t with - Z0 => constr:(true) - | Zpos ?p => isPcst p - | Zneg ?p => isPcst p - (* injection nat -> Z *) - | Z.of_nat ?n => isnatcst n - (* injection N -> Z *) - | Z.of_N ?n => isNcst n - (* *) - | _ => constr:(false) - end. diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v deleted file mode 100644 index f1394c51d5..0000000000 --- a/plugins/setoid_ring/Integral_domain.v +++ /dev/null @@ -1,53 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Cring. - - -(* Definition of integral domains: commutative ring without zero divisor *) - -Class Integral_domain {R : Type}`{Rcr:Cring R} := { - integral_domain_product: - forall x y, x * y == 0 -> x == 0 \/ y == 0; - integral_domain_one_zero: not (1 == 0)}. - -Section integral_domain. - -Context {R:Type}`{Rid:Integral_domain R}. - -Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0. -red;intro. apply integral_domain_one_zero. -assert (0 == - (0:R)). cring. -rewrite H0. rewrite <- H. cring. -Qed. - - -Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n). - -Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. -induction n. unfold pow; simpl. intros. absurd (1 == 0). -simpl. apply integral_domain_one_zero. - trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). -intros. -case (integral_domain_product p (pow p n) H). trivial. trivial. -unfold pow; simpl. -clear IHn. induction n; simpl; try cring. - rewrite Ring_theory.pow_pos_succ. cring. apply ring_setoid. -apply ring_mult_comp. -apply ring_mul_assoc. -Qed. - -Lemma Rintegral_domain_pow: - forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0. -intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto. -intros. apply pow_not_zero with r. trivial. Qed. - -End integral_domain. - diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v deleted file mode 100644 index 8cda4ad714..0000000000 --- a/plugins/setoid_ring/NArithRing.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Ring. -Require Import BinPos BinNat. -Import InitialRing. - -Set Implicit Arguments. - -Ltac Ncst t := - match isNcst t with - true => t - | _ => constr:(NotConstant) - end. - -Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v deleted file mode 100644 index 8f3de26272..0000000000 --- a/plugins/setoid_ring/Ncring.v +++ /dev/null @@ -1,308 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* non commutative rings *) - -Require Import Setoid. -Require Import BinPos. -Require Import BinNat. -Require Export Morphisms Setoid Bool. -Require Export ZArith_base. -Require Export Algebra_syntax. - -Set Implicit Arguments. - -Class Ring_ops(T:Type) - {ring0:T} - {ring1:T} - {add:T->T->T} - {mul:T->T->T} - {sub:T->T->T} - {opp:T->T} - {ring_eq:T->T->Prop}. - -Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. -Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1. -Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add. -Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul. -Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub. -Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp. -Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq. - -Class Ring `{Ro:Ring_ops}:={ - ring_setoid: Equivalence _==_; - ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_; - ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_; - ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_; - ring_opp_comp: Proper (_==_==>_==_) -_; - ring_add_0_l : forall x, 0 + x == x; - ring_add_comm : forall x y, x + y == y + x; - ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z; - ring_mul_1_l : forall x, 1 * x == x; - ring_mul_1_r : forall x, x * 1 == x; - ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z; - ring_distr_l : forall x y z, (x + y) * z == x * z + y * z; - ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y; - ring_sub_def : forall x y, x - y == x + -y; - ring_opp_def : forall x, x + -x == 0 -}. -(* inutile! je sais plus pourquoi j'ai mis ca... -Instance ring_Ring_ops(R:Type)`{Ring R} - :@Ring_ops R 0 1 addition multiplication subtraction opposite equality. -*) -Existing Instance ring_setoid. -Existing Instance ring_plus_comp. -Existing Instance ring_mult_comp. -Existing Instance ring_sub_comp. -Existing Instance ring_opp_comp. - -Section Ring_power. - -Context {R:Type}`{Ring R}. - - Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos x i in p * p - | xI i => let p := pow_pos x i in x * (p * p) - end. - - Definition pow_N (x:R) (p:N) := - match p with - | N0 => 1 - | Npos p => pow_pos x p - end. - -End Ring_power. - -Definition ZN(x:Z):= - match x with - Z0 => N0 - |Zpos p | Zneg p => Npos p -end. - -Instance power_ring {R:Type}`{Ring R} : Power:= - {power x y := pow_N x (ZN y)}. - -(** Interpretation morphisms definition*) - -Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= { - ring_morphism0 : [0] == 0; - ring_morphism1 : [1] == 1; - ring_morphism_add : forall x y, [x + y] == [x] + [y]; - ring_morphism_sub : forall x y, [x - y] == [x] - [y]; - ring_morphism_mul : forall x y, [x * y] == [x] * [y]; - ring_morphism_opp : forall x, [-x] == -[x]; - ring_morphism_eq : forall x y, x == y -> [x] == [y]}. - -Section Ring. - -Context {R:Type}`{Rr:Ring R}. - -(* Powers *) - -Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x. -Proof. -induction j; simpl. rewrite <- ring_mul_assoc. -rewrite <- ring_mul_assoc. -rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). -rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity. -rewrite <- ring_mul_assoc. rewrite <- IHj. -rewrite ring_mul_assoc. rewrite IHj. -rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. reflexivity. -Qed. - -Lemma pow_pos_succ : forall x j, pow_pos x (Pos.succ j) == x * pow_pos x j. -Proof. -induction j; simpl. - rewrite IHj. -rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)). -rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). - rewrite <- pow_pos_comm. -rewrite <- ring_mul_assoc. reflexivity. -reflexivity. reflexivity. -Qed. - -Lemma pow_pos_add : forall x i j, - pow_pos x (i + j) == pow_pos x i * pow_pos x j. -Proof. - intro x;induction i;intros. - rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r. - rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. - repeat rewrite IHi. - rewrite Pos.add_comm;rewrite Pos.add_1_r; - rewrite pow_pos_succ. - simpl;repeat rewrite ring_mul_assoc. reflexivity. - rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. - repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. - rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ. - simpl. reflexivity. - Qed. - - Definition id_phi_N (x:N) : N := x. - - Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. - Proof. - intros; reflexivity. - Qed. - - (** Identity is a morphism *) - (* - Instance IDmorph : Ring_morphism _ _ _ (fun x => x). - Proof. - apply (Build_Ring_morphism H6 H6 (fun x => x));intros; - try reflexivity. trivial. - Qed. -*) - (** rings are almost rings*) - Lemma ring_mul_0_l : forall x, 0 * x == 0. - Proof. - intro x. setoid_replace (0*x) with ((0+1)*x + -x). - rewrite ring_add_0_l. rewrite ring_mul_1_l . - rewrite ring_opp_def . fold zero. reflexivity. - rewrite ring_distr_l . rewrite ring_mul_1_l . - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_mul_0_r : forall x, x * 0 == 0. - Proof. - intro x; setoid_replace (x*0) with (x*(0+1) + -x). - rewrite ring_add_0_l ; rewrite ring_mul_1_r . - rewrite ring_opp_def ; fold zero; reflexivity. - - rewrite ring_distr_r ;rewrite ring_mul_1_r . - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y. - Proof. - intros x y;rewrite <- (ring_add_0_l (- x * y)). - rewrite ring_add_comm . - rewrite <- (ring_opp_def (x*y)). - rewrite ring_add_assoc . - rewrite <- ring_distr_l. - rewrite (ring_add_comm (-x));rewrite ring_opp_def . - rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity. - Qed. - -Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y. - Proof. - intros x y;rewrite <- (ring_add_0_l (x * - y)). - rewrite ring_add_comm . - rewrite <- (ring_opp_def (x*y)). - rewrite ring_add_assoc . - rewrite <- ring_distr_r . - rewrite (ring_add_comm (-y));rewrite ring_opp_def . - rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity. - Qed. - - Lemma ring_opp_add : forall x y, -(x + y) == -x + -y. - Proof. - intros x y;rewrite <- (ring_add_0_l (-(x+y))). - rewrite <- (ring_opp_def x). - rewrite <- (ring_add_0_l (x + - x + - (x + y))). - rewrite <- (ring_opp_def y). - rewrite (ring_add_comm x). - rewrite (ring_add_comm y). - rewrite <- (ring_add_assoc (-y)). - rewrite <- (ring_add_assoc (- x)). - rewrite (ring_add_assoc y). - rewrite (ring_add_comm y). - rewrite <- (ring_add_assoc (- x)). - rewrite (ring_add_assoc y). - rewrite (ring_add_comm y);rewrite ring_opp_def . - rewrite (ring_add_comm (-x) 0);rewrite ring_add_0_l . - rewrite ring_add_comm; reflexivity. - Qed. - - Lemma ring_opp_opp : forall x, - -x == x. - Proof. - intros x; rewrite <- (ring_add_0_l (- -x)). - rewrite <- (ring_opp_def x). - rewrite <- ring_add_assoc ; rewrite ring_opp_def . - rewrite (ring_add_comm x); rewrite ring_add_0_l . reflexivity. - Qed. - - Lemma ring_sub_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. - Proof. - intros. - setoid_replace (x1 - y1) with (x1 + -y1). - setoid_replace (x2 - y2) with (x2 + -y2). - rewrite H;rewrite H0;reflexivity. - rewrite ring_sub_def. reflexivity. - rewrite ring_sub_def. reflexivity. - Qed. - - Ltac mrewrite := - repeat first - [ rewrite ring_add_0_l - | rewrite <- (ring_add_comm 0) - | rewrite ring_mul_1_l - | rewrite ring_mul_0_l - | rewrite ring_distr_l - | reflexivity - ]. - - Lemma ring_add_0_r : forall x, (x + 0) == x. - Proof. intros; mrewrite. Qed. - - - Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x. - Proof. - intros;rewrite <- (ring_add_assoc x). - rewrite (ring_add_comm x);reflexivity. - Qed. - - Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x. - Proof. - intros; repeat rewrite <- ring_add_assoc. - rewrite (ring_add_comm x); reflexivity. - Qed. - - Lemma ring_opp_zero : -0 == 0. - Proof. - rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l. - repeat rewrite ring_mul_0_r. reflexivity. - Qed. - -End Ring. - -(** Some simplification tactics*) -Ltac gen_reflexivity := reflexivity. - -Ltac gen_rewrite := - repeat first - [ reflexivity - | progress rewrite ring_opp_zero - | rewrite ring_add_0_l - | rewrite ring_add_0_r - | rewrite ring_mul_1_l - | rewrite ring_mul_1_r - | rewrite ring_mul_0_l - | rewrite ring_mul_0_r - | rewrite ring_distr_l - | rewrite ring_distr_r - | rewrite ring_add_assoc - | rewrite ring_mul_assoc - | progress rewrite ring_opp_add - | progress rewrite ring_sub_def - | progress rewrite <- ring_opp_mul_l - | progress rewrite <- ring_opp_mul_r ]. - -Ltac gen_add_push x := -repeat (match goal with - | |- context [(?y + x) + ?z] => - progress rewrite (ring_add_assoc2 x y z) - | |- context [(x + ?y) + ?z] => - progress rewrite (ring_add_assoc1 x y z) - end). diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v deleted file mode 100644 index e40ef6056d..0000000000 --- a/plugins/setoid_ring/Ncring_initial.v +++ /dev/null @@ -1,214 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import ZArith_base. -Require Import Zpow_def. -Require Import BinInt. -Require Import BinNat. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Import Setoid. -Require Export Ncring. -Require Export Ncring_polynom. - -Set Implicit Arguments. - -(* An object to return when an expression is not recognized as a constant *) -Definition NotConstant := false. - -(** Z is a ring and a setoid*) - -Lemma Zsth : Equivalence (@eq Z). -Proof. exact Z.eq_equiv. Qed. - -Instance Zops:@Ring_ops Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z). -Defined. - -Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops). -Proof. -constructor; try apply Zsth; try solve_proper. - exact Z.add_comm. exact Z.add_assoc. - exact Z.mul_1_l. exact Z.mul_1_r. exact Z.mul_assoc. - exact Z.mul_add_distr_r. intros; apply Z.mul_add_distr_l. exact Z.sub_diag. -Defined. - -(*Instance ZEquality: @Equality Z:= (@eq Z).*) - -(** Two generic morphisms from Z to (arbitrary) rings, *) -(**second one is more convenient for proofs but they are ext. equal*) -Section ZMORPHISM. -Context {R:Type}`{Ring R}. - - Ltac rrefl := reflexivity. - - Fixpoint gen_phiPOS1 (p:positive) : R := - match p with - | xH => 1 - | xO p => (1 + 1) * (gen_phiPOS1 p) - | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) - end. - - Fixpoint gen_phiPOS (p:positive) : R := - match p with - | xH => 1 - | xO xH => (1 + 1) - | xO p => (1 + 1) * (gen_phiPOS p) - | xI xH => 1 + (1 +1) - | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) - end. - - Definition gen_phiZ1 z := - match z with - | Zpos p => gen_phiPOS1 p - | Z0 => 0 - | Zneg p => -(gen_phiPOS1 p) - end. - - Definition gen_phiZ z := - match z with - | Zpos p => gen_phiPOS p - | Z0 => 0 - | Zneg p => -(gen_phiPOS p) - end. - Declare Scope ZMORPHISM. - Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. - Open Scope ZMORPHISM. - - Definition get_signZ z := - match z with - | Zneg p => Some (Zpos p) - | _ => None - end. - - Ltac norm := gen_rewrite. - Ltac add_push := Ncring.gen_add_push. -Ltac rsimpl := simpl. - - Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. - Proof. - induction x;rsimpl. - rewrite IHx. destruct x;simpl;norm. - rewrite IHx;destruct x;simpl;norm. - reflexivity. - Qed. - - Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). - Proof. - induction x;rsimpl;norm. - rewrite IHx. gen_rewrite. add_push 1. reflexivity. - Qed. - - Lemma ARgen_phiPOS_add : forall x y, - gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). - Proof. - induction x;destruct y;simpl;norm. - rewrite Pos.add_carry_spec. - rewrite ARgen_phiPOS_Psucc. - rewrite IHx;norm. - add_push (gen_phiPOS1 y);add_push 1;reflexivity. - rewrite IHx;norm;add_push (gen_phiPOS1 y);reflexivity. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. - rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;reflexivity. - rewrite IHx;norm;add_push(gen_phiPOS1 y);reflexivity. - add_push 1;reflexivity. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. - Qed. - - Lemma ARgen_phiPOS_mult : - forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. - Proof. - induction x;intros;simpl;norm. - rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. - rewrite IHx;reflexivity. - Qed. - - -(*morphisms are extensionally equal*) - Lemma same_genZ : forall x, [x] == gen_phiZ1 x. - Proof. - destruct x;rsimpl; try rewrite same_gen; reflexivity. - Qed. - - Lemma gen_Zeqb_ok : forall x y, - Zeq_bool x y = true -> [x] == [y]. - Proof. - intros x y H7. - assert (H10 := Zeq_bool_eq x y H7);unfold IDphi in H10. - rewrite H10;reflexivity. - Qed. - - Lemma gen_phiZ1_add_pos_neg : forall x y, - gen_phiZ1 (Z.pos_sub x y) - == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - generalize (Z.pos_sub_discr x y). - destruct (Z.pos_sub x y) as [|p|p]; intros; subst. - - now rewrite ring_opp_def. - - rewrite ARgen_phiPOS_add;simpl;norm. - add_push (gen_phiPOS1 p). rewrite ring_opp_def;norm. - - rewrite ARgen_phiPOS_add;simpl;norm. - rewrite ring_opp_def;norm. - Qed. - - Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end - = match x with Eq => be | Lt => bg | Gt => bl end. - Proof. destruct x;simpl;intros;trivial. Qed. - - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - induction x;destruct y;simpl;norm. - apply ARgen_phiPOS_add. - apply gen_phiZ1_add_pos_neg. - rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm. -reflexivity. - rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity. -Qed. - -Lemma gen_phiZ_opp : forall x, [- x] == - [x]. - Proof. - intros x. repeat rewrite same_genZ. generalize x ;clear x. - induction x;simpl;norm. - rewrite ring_opp_opp. reflexivity. - Qed. - - Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genZ. - destruct x;destruct y;simpl;norm; - rewrite ARgen_phiPOS_mult;try (norm;fail). - rewrite ring_opp_opp ;reflexivity. - Qed. - - Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. - Proof. intros;subst;reflexivity. Qed. - -Declare Equivalent Keys bracket gen_phiZ. -(*proof that [.] satisfies morphism specifications*) -Global Instance gen_phiZ_morph : -(@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) - apply Build_Ring_morphism; simpl;try reflexivity. - apply gen_phiZ_add. intros. rewrite ring_sub_def. -replace (x-y)%Z with (x + (-y))%Z. -now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def. -reflexivity. - apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext. - Defined. - -End ZMORPHISM. - -Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication := - {multiplication x y := (gen_phiZ x) * y}. diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v deleted file mode 100644 index 048c8eecf9..0000000000 --- a/plugins/setoid_ring/Ncring_polynom.v +++ /dev/null @@ -1,594 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* A <X1,...,Xn>: non commutative polynomials on a commutative ring A *) - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Export Ring_polynom. (* n'utilise que PExpr *) -Require Export Ncring. - -Section MakeRingPol. - -Context (C R:Type) `{Rh:Ring_morphism C R}. - -Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. - - Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm). - Ltac add_push := gen_add_push . - -(* Definition of non commutative multivariable polynomials - with coefficients in C : - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | PX : Pol -> positive -> positive -> Pol -> Pol. - (* PX P i n Q represents P * X_i^n + Q *) -Definition cO:C . exact ring0. Defined. -Definition cI:C . exact ring1. Defined. - - Definition P0 := Pc 0. - Definition P1 := Pc 1. - -Variable Ceqb:C->C->bool. -#[universes(template)] -Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. -Notation "x =? y" := (equalityb x y) (at level 70, no associativity). -Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). - -Instance equalityb_coef : Equalityb C := - {equalityb x y := Ceqb x y}. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c =? c' - | PX P i n Q, PX P' i' n' Q' => - match Pos.compare i i', Pos.compare n n' with - | Eq, Eq => if Peq P P' then Peq Q Q' else false - | _,_ => false - end - | _, _ => false - end. - -Instance equalityb_pol : Equalityb Pol := - {equalityb x y := Peq x y}. - -(* Q a ses variables de queue < i *) - Definition mkPX P i n Q := - match P with - | Pc c => if c =? 0 then Q else PX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q - | _ => PX P i n Q - end - end. - - Definition mkXi i n := PX P1 i n P0. - - Definition mkX i := mkXi i 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (- c) - | PX P i n Q => PX (Popp P) i n (Popp Q) - end. - - Notation "-- P" := (Popp P)(at level 30). - - (** Addition et subtraction *) - - Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol := - match P with - | Pc c1 => Pc (c + c1) - | PX P i n Q => PX P i n (PaddCl c Q) - end. - -(* Q quelconque *) - -Section PaddX. -Variable Padd:Pol->Pol->Pol. -Variable P:Pol. - -(* Xi^n * P + Q -les variables de tete de Q ne sont pas forcement < i -mais Q est normalisé : variables de tete decroissantes *) - -Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:= - match Q with - | Pc c => mkPX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | (* i > i' *) - Gt => mkPX P i n Q - | (* i < i' *) - Lt => mkPX P' i' n' (PaddX i n Q') - | (* i = i' *) - Eq => match Z.pos_sub n n' with - | (* n > n' *) - Zpos k => mkPX (PaddX i k P') i' n' Q' - | (* n = n' *) - Z0 => mkPX (Padd P P') i n Q' - | (* n < n' *) - Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' - end - end - end. - -End PaddX. - -Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol := - match P1 with - | Pc c => PaddCl c P2 - | PX P' i' n' Q' => - PaddX Padd P' i' n' (Padd Q' P2) - end. - - Notation "P ++ P'" := (Padd P P'). - -Definition Psub(P P':Pol):= P ++ (--P'). - - Notation "P -- P'" := (Psub P P')(at level 50). - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c' => Pc (c' * c) - | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c =? 0 then P0 else - if c =? 1 then P else PmulC_aux P c. - - Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol := - match P2 with - | Pc c => PmulC P1 c - | PX P i n Q => - PaddX Padd (Pmul P1 P) i n (Pmul P1 Q) - end. - - Notation "P ** P'" := (Pmul P P')(at level 40). - - Definition Psquare (P:Pol) : Pol := P ** P. - - - (** Evaluation of a polynomial towards R *) - - Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | PX P i n Q => - let x := nth 0 i l in - let xn := pow_pos x n in - (Pphi l P) * xn + (Pphi l Q) - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - - (** Proofs *) - - Ltac destr_pos_sub H := - match goal with |- context [Z.pos_sub ?x ?y] => - assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - - Lemma Peq_ok : forall P P', - (P =? P') = true -> forall l, P@l == P'@ l. - Proof. - induction P;destruct P';simpl;intros ;try easy. - - now apply ring_morphism_eq, Ceqb_eq. - - specialize (IHP1 P'1). specialize (IHP2 P'2). - simpl in IHP1, IHP2. - destruct (Pos.compare_spec p p1); try discriminate; - destruct (Pos.compare_spec p0 p2); try discriminate. - destruct (Peq P2 P'1); try discriminate. - subst; now rewrite IHP1, IHP2. - Qed. - - Lemma Pphi0 : forall l, P0@l == 0. - Proof. - intros;simpl. - rewrite ring_morphism0. reflexivity. - Qed. - - Lemma Pphi1 : forall l, P1@l == 1. - Proof. - intros;simpl; rewrite ring_morphism1. reflexivity. - Qed. - - Lemma mkPX_ok : forall l P i n Q, - (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l. - Proof. - intros l P i n Q;unfold mkPX. - destruct P;try (simpl;reflexivity). - assert (Hh := ring_morphism_eq c 0). - simpl; case_eq (Ceqb c 0);simpl;try reflexivity. - intros. - rewrite Hh. rewrite ring_morphism0. - rsimpl. apply Ceqb_eq. trivial. - destruct (Pos.compare_spec i p). - assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. - rewrite Hh. - rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl. - subst;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity. - simpl. reflexivity. - Qed. - -Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [?P@?l] => - match P with - | P0 => rewrite (Pphi0 l) - | P1 => rewrite (Pphi1 l) - | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q) - end - | |- context [[?c]] => - match c with - | 0 => rewrite ring_morphism0 - | 1 => rewrite ring_morphism1 - | ?x + ?y => rewrite ring_morphism_add - | ?x * ?y => rewrite ring_morphism_mul - | ?x - ?y => rewrite ring_morphism_sub - | - ?x => rewrite ring_morphism_opp - end - end)); - simpl; rsimpl. - - Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l . - Proof. - induction P; simpl; intros; Esimpl; try reflexivity. - rewrite IHP2. rsimpl. -rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) [c]). -reflexivity. - Qed. - - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. - Proof. - induction P;simpl;intros. rewrite ring_morphism_mul. -try reflexivity. - simpl. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. - Proof. - intros c P l; unfold PmulC. - assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros. - rewrite Hh;Esimpl. apply Ceqb_eq;trivial. - assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros. - rewrite H1h;Esimpl. apply Ceqb_eq;trivial. - apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok : forall P l, (--P)@l == - P@l. - Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP1;rewrite IHP2;rsimpl. - Qed. - - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - -Lemma PaddXPX: forall P i n Q, - PaddX Padd P i n Q = - match Q with - | Pc c => mkPX P i n Q - | PX P' i' n' Q' => - match Pos.compare i i' with - | (* i > i' *) - Gt => mkPX P i n Q - | (* i < i' *) - Lt => mkPX P' i' n' (PaddX Padd P i n Q') - | (* i = i' *) - Eq => match Z.pos_sub n n' with - | (* n > n' *) - Zpos k => mkPX (PaddX Padd P i k P') i' n' Q' - | (* n = n' *) - Z0 => mkPX (Padd P P') i n Q' - | (* n < n' *) - Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' - end - end - end. -induction Q; reflexivity. -Qed. - -Lemma PaddX_ok2 : forall P2, - (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l) - /\ - (forall P k n l, - (PaddX Padd P2 k n P) @ l == - P2 @ l * pow_pos (nth 0 k l) n + P @ l). -induction P2;simpl;intros. split. intros. apply PaddCl_ok. - induction P. unfold PaddX. intros. rewrite mkPX_ok. - simpl. rsimpl. -intros. simpl. - destruct (Pos.compare_spec k p) as [Hh|Hh|Hh]. - destr_pos_sub H1h. Esimpl2. -rewrite Hh; trivial. rewrite H1h. reflexivity. -simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2. - rewrite Pos.add_comm in H1h. -rewrite H1h. -rewrite pow_pos_add. Esimpl2. -rewrite Hh; trivial. reflexivity. -rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h. -rewrite H1h. Esimpl2. rewrite pow_pos_add. Esimpl2. -rewrite Hh; trivial. reflexivity. -rewrite mkPX_ok. rewrite IHP2. Esimpl2. -rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) - ([c] * pow_pos (nth 0 k l) n)). -reflexivity. assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c 0); - intros; simpl. -rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity. -decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2. -split. intros. rewrite H0. rewrite H1. -Esimpl2. -induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity. -intros. rewrite PaddXPX. -destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h]. -destr_pos_sub H4h. -rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2. -rewrite H4h. rewrite H3h;trivial. reflexivity. -rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial. -rewrite Pos.add_comm in H4h. -rewrite H4h. rewrite pow_pos_add. Esimpl2. -rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. -rewrite mkPX_ok. - Esimpl2. rewrite H3h;trivial. - rewrite Pos.add_comm in H4h. -rewrite H4h. rewrite pow_pos_add. Esimpl2. -rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2. -gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity. -rewrite mkPX_ok. simpl. reflexivity. -Qed. - -Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l. -intro P. elim (PaddX_ok2 P); auto. -Qed. - -Lemma PaddX_ok : forall P2 P k n l, - (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l. -intro P2. elim (PaddX_ok2 P2); auto. -Qed. - - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. -unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl. - Qed. - - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. -induction P'; simpl; intros. rewrite PmulC_ok. reflexivity. -rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2. -Qed. - - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. - Proof. - intros. unfold Psquare. apply Pmul_ok. - Qed. - - (** Definition of polynomial expressions *) - -(* - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. -*) - - (** Specification of the power function *) - Section POWER. - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - - Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, (rpow r (Cp_phi n))== (pow_N r n) - }. - - End POWER. - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory Cp_phi rpow. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R := - match pe with - | PEO => 0 - | PEI => 1 - | PEc c => [c] - | PEX _ j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - -Strategy expand [PEeval]. - - Definition mk_X j := mkX j. - - (** Correctness proofs *) - - Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - Qed. - - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l) - end;try Esimpl2;try reflexivity;try apply ring_add_comm. - -(* Power using the chinise algorithm *) - -Section POWER2. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => subst_l (Pmul P res) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p)) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos_gen m x i in m p p - | xI i => let p := pow_pos_gen m x i in m x (m p p) - end. - -Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l. - Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros. try rewrite subst_l_ok. - repeat rewrite Pmul_ok. repeat rewrite IHp. - rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. - try rewrite subst_l_ok. - repeat rewrite Pmul_ok. reflexivity. - Qed. - -Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := - match p with - | N0 => x1 - | Npos p => pow_pos_gen m x p - end. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l. - Proof. destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl. Qed. - - End POWER2. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Let subst_l (P:Pol) := P. - Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr C) : Pol := - match pe with - | PEO => Pc cO - | PEI => Pc cI - | PEc c => Pc c - | PEX _ j => mk_X j - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - - Lemma norm_aux_spec : - forall l pe, - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe. - - now simpl; rewrite <- ring_morphism0. - - now simpl; rewrite <- ring_morphism1. - - Esimpl3. - - Esimpl3. - - simpl. - rewrite IHpe1;rewrite IHpe2. - destruct pe2; Esimpl3. - unfold Psub. - destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. - - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. - now destruct pe1; - [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..]. - - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. - - now simpl; rewrite IHpe; Esimpl3. - - simpl. - rewrite Ppow_N_ok; (intros;try reflexivity). - rewrite rpow_pow_N; [| now apply pow_th]. - induction n;simpl; [now Esimpl3|]. - induction p; simpl; trivial. - + try rewrite IHp;try rewrite IHpe; - repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity. - + rewrite Pmul_ok. - try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;reflexivity. - Qed. - - Lemma norm_subst_spec : - forall l pe, - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;unfold norm_subst. - unfold subst_l. apply norm_aux_spec. - Qed. - - End NORM_SUBST_REC. - - Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop := - match lpe with - | nil => True - | (me,pe)::lpe => - match lpe with - | nil => PEeval l me == PEeval l pe - | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe - end - end. - - - Lemma norm_subst_ok : forall l pe, - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;apply norm_subst_spec. - Qed. - - - Lemma ring_correct : forall l pe1 pe2, - (norm_subst pe1 =? norm_subst pe2) = true -> - PEeval l pe1 == PEeval l pe2. - Proof. - simpl;intros. - do 2 (rewrite (norm_subst_ok l);trivial). - apply Peq_ok;trivial. - Qed. - -End MakeRingPol. diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v deleted file mode 100644 index 65233873b1..0000000000 --- a/plugins/setoid_ring/Ncring_tac.v +++ /dev/null @@ -1,328 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import List. -Require Import Setoid. -Require Import BinPos. -Require Import BinList. -Require Import Znumtheory. -Require Export Morphisms Setoid Bool. -Require Import ZArith. -Require Import Algebra_syntax. -Require Export Ncring. -Require Import Ncring_polynom. -Require Import Ncring_initial. - - -Set Implicit Arguments. - -Class nth (R:Type) (t:R) (l:list R) (i:nat). - -Instance Ifind0 (R:Type) (t:R) l - : nth t(t::l) 0. -Defined. - -Instance IfindS (R:Type) (t2 t1:R) l i - {_:nth t1 l i} - : nth t1 (t2::l) (S i) | 1. -Defined. - -Class closed (T:Type) (l:list T). - -Instance Iclosed_nil T - : closed (T:=T) nil. -Defined. - -Instance Iclosed_cons T t (l:list T) - {_:closed l} - : closed (t::l). -Defined. - -Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R). - -Instance reify_zero (R:Type) lvar op - `{Ring (T:=R)(ring0:=op)} - : reify (ring0:=op)(PEc 0%Z) lvar op. -Defined. - -Instance reify_one (R:Type) lvar op - `{Ring (T:=R)(ring1:=op)} - : reify (ring1:=op) (PEc 1%Z) lvar op. -Defined. - -Instance reifyZ0 (R:Type) lvar - `{Ring (T:=R)} - : reify (PEc Z0) lvar Z0|11. -Defined. - -Instance reifyZpos (R:Type) lvar (p:positive) - `{Ring (T:=R)} - : reify (PEc (Zpos p)) lvar (Zpos p)|11. -Defined. - -Instance reifyZneg (R:Type) lvar (p:positive) - `{Ring (T:=R)} - : reify (PEc (Zneg p)) lvar (Zneg p)|11. -Defined. - -Instance reify_add (R:Type) - e1 lvar t1 e2 t2 op - `{Ring (T:=R)(add:=op)} - {_:reify (add:=op) e1 lvar t1} - {_:reify (add:=op) e2 lvar t2} - : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2). -Defined. - -Instance reify_mul (R:Type) - e1 lvar t1 e2 t2 op - `{Ring (T:=R)(mul:=op)} - {_:reify (mul:=op) e1 lvar t1} - {_:reify (mul:=op) e2 lvar t2} - : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10. -Defined. - -Instance reify_mul_ext (R:Type) `{Ring R} - lvar (z:Z) e2 t2 - `{Ring (T:=R)} - {_:reify e2 lvar t2} - : reify (PEmul (PEc z) e2) lvar - (@multiplication Z _ _ z t2)|9. -Defined. - -Instance reify_sub (R:Type) - e1 lvar t1 e2 t2 op - `{Ring (T:=R)(sub:=op)} - {_:reify (sub:=op) e1 lvar t1} - {_:reify (sub:=op) e2 lvar t2} - : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2). -Defined. - -Instance reify_opp (R:Type) - e1 lvar t1 op - `{Ring (T:=R)(opp:=op)} - {_:reify (opp:=op) e1 lvar t1} - : reify (opp:=op) (PEopp e1) lvar (op t1). -Defined. - -Instance reify_pow (R:Type) `{Ring R} - e1 lvar t1 n - `{Ring (T:=R)} - {_:reify e1 lvar t1} - : reify (PEpow e1 n) lvar (pow_N t1 n)|1. -Defined. - -Instance reify_var (R:Type) t lvar i - `{nth R t lvar i} - `{Rr: Ring (T:=R)} - : reify (Rr:= Rr) (PEX Z (Pos.of_succ_nat i))lvar t - | 100. -Defined. - -Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) - (lterm:list R). - -Instance reify_nil (R:Type) lvar - `{Rr: Ring (T:=R)} - : reifylist (Rr:= Rr) nil lvar (@nil R). -Defined. - -Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2 - `{Rr: Ring (T:=R)} - {_:reify (Rr:= Rr) e1 lvar t1} - {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2} - : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2). -Defined. - -Definition list_reifyl (R:Type) lexpr lvar lterm - `{Rr: Ring (T:=R)} - {_:reifylist (Rr:= Rr) lexpr lvar lterm} - `{closed (T:=R) lvar} := (lvar,lexpr). - -Unset Implicit Arguments. - -Ltac lterm_goal g := - match g with - | ?t1 == ?t2 => constr:(t1::t2::nil) - | ?t1 = ?t2 => constr:(t1::t2::nil) - | (_ ?t1 ?t2) => constr:(t1::t2::nil) - end. - -Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y. - intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. - - -Ltac reify_goal lvar lexpr lterm:= - (*idtac lvar; idtac lexpr; idtac lterm;*) - match lexpr with - nil => idtac - | ?e1::?e2::_ => - match goal with - |- (?op ?u1 ?u2) => - change (op - (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N - (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) - lvar e1) - (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N - (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) - lvar e2)) - end - end. - -Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R), - x * (gen_phiZ c) == (gen_phiZ c) * x. -induction c. intros. simpl. gen_rewrite. simpl. intros. -rewrite <- same_gen. -induction p. simpl. gen_rewrite. rewrite IHp. reflexivity. -simpl. gen_rewrite. rewrite IHp. reflexivity. -simpl. gen_rewrite. -simpl. intros. rewrite <- same_gen. -induction p. simpl. generalize IHp. clear IHp. -gen_rewrite. intro IHp. rewrite IHp. reflexivity. -simpl. generalize IHp. clear IHp. -gen_rewrite. intro IHp. rewrite IHp. reflexivity. -simpl. gen_rewrite. Qed. - -Ltac ring_gen := - match goal with - |- ?g => let lterm := lterm_goal g in - match eval red in (list_reifyl (lterm:=lterm)) with - | (?fv, ?lexpr) => - (*idtac "variables:";idtac fv; - idtac "terms:"; idtac lterm; - idtac "reifications:"; idtac lexpr; *) - reify_goal fv lexpr lterm; - match goal with - |- ?g => - apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - (@gen_phiZ _ _ _ _ _ _ _ _ _) _ - (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n) - (@pow_N _ _ _ _ _ _ _ _ _)); - [apply mkpow_th; reflexivity - |vm_compute; reflexivity] - end - end - end. - -Ltac non_commutative_ring:= - intros; - ring_gen. - -(* simplification *) - -Ltac ring_simplify_aux lterm fv lexpr hyp := - match lterm with - | ?t0::?lterm => - match lexpr with - | ?e::?le => (* e:PExpr Z est la réification de t0:R *) - let t := constr:(@Ncring_polynom.norm_subst - Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) Zops Zeq_bool e) in - (* t:Pol Z *) - let te := - constr:(@Ncring_polynom.Pphi Z - _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in - let eq1 := fresh "ring" in - let nft := eval vm_compute in t in - let t':= fresh "t" in - pose (t' := nft); - assert (eq1 : t = t'); - [vm_cast_no_check (eq_refl t')| - let eq2 := fresh "ring" in - assert (eq2:(@Ncring_polynom.PEeval Z - _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) - (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); - [apply (@Ncring_polynom.norm_subst_ok - Z _ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) - _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _ - (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Zeqb_ok); - apply mkpow_th; reflexivity - | match hyp with - | 1%nat => rewrite eq2 - | ?H => try rewrite eq2 in H - end]; - let P:= fresh "P" in - match hyp with - | 1%nat => idtac "ok"; - rewrite eq1; - pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ - _ Ncring_initial.gen_phiZ fv t'); - match goal with - |- (?p ?t) => set (P:=p) - end; - unfold t' in *; clear t' eq1 eq2; simpl - | ?H => - rewrite eq1 in H; - pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ - _ Ncring_initial.gen_phiZ fv t') in H; - match type of H with - | (?p ?t) => set (P:=p) in H - end; - unfold t' in *; clear t' eq1 eq2; simpl in H - end; unfold P in *; clear P - ]; ring_simplify_aux lterm fv le hyp - | nil => idtac - end - | nil => idtac - end. - -Ltac set_variables fv := - match fv with - | nil => idtac - | ?t::?fv => - let v := fresh "X" in - set (v:=t) in *; set_variables fv - end. - -Ltac deset n:= - match n with - | 0%nat => idtac - | S ?n1 => - match goal with - | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 - end - end. - -(* a est soit un terme de l'anneau, soit une liste de termes. -J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list - dans Tactic Notation *) - -Ltac ring_simplify_gen a hyp := - let lterm := - match a with - | _::_ => a - | _ => constr:(a::nil) - end in - match eval red in (list_reifyl (lterm:=lterm)) with - | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; - let n := eval compute in (length fv) in - idtac n; - let lt:=fresh "lt" in - set (lt:= lterm); - let lv:=fresh "fv" in - set (lv:= fv); - (* les termes de fv sont remplacés par des variables - pour pouvoir utiliser simpl ensuite sans risquer - des simplifications indésirables *) - set_variables fv; - let lterm1 := eval unfold lt in lt in - let lv1 := eval unfold lv in lv in - idtac lterm1; idtac lv1; - ring_simplify_aux lterm1 lv1 lexpr hyp; - clear lt lv; - (* on remet les termes de fv *) - deset n - end. - -Tactic Notation "non_commutative_ring_simplify" constr(lterm):= - ring_simplify_gen lterm 1%nat. - -Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):= - ring_simplify_gen lterm H. - - diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v deleted file mode 100644 index d83fcf3781..0000000000 --- a/plugins/setoid_ring/RealField.v +++ /dev/null @@ -1,158 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Nnat. -Require Import ArithRing. -Require Export Ring Field. -Require Import Rdefinitions. -Require Import Rpow_def. -Require Import Raxioms. - -Local Open Scope R_scope. - -Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). -Proof. -constructor. - intro; apply Rplus_0_l. - exact Rplus_comm. - symmetry ; apply Rplus_assoc. - intro; apply Rmult_1_l. - exact Rmult_comm. - symmetry ; apply Rmult_assoc. - intros m n p. - rewrite Rmult_comm. - rewrite (Rmult_comm n p). - rewrite (Rmult_comm m p). - apply Rmult_plus_distr_l. - reflexivity. - exact Rplus_opp_r. -Qed. - -Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). -Proof. -constructor. - exact RTheory. - exact R1_neq_R0. - reflexivity. - exact Rinv_l. -Qed. - -Lemma Rlt_n_Sn : forall x, x < x + 1. -Proof. -intro. -elim archimed with x; intros. -destruct H0. - apply Rlt_trans with (IZR (up x)); trivial. - replace (IZR (up x)) with (x + (IZR (up x) - x))%R. - apply Rplus_lt_compat_l; trivial. - unfold Rminus. - rewrite (Rplus_comm (IZR (up x)) (- x)). - rewrite <- Rplus_assoc. - rewrite Rplus_opp_r. - apply Rplus_0_l. - elim H0. - unfold Rminus. - rewrite (Rplus_comm (IZR (up x)) (- x)). - rewrite <- Rplus_assoc. - rewrite Rplus_opp_r. - rewrite Rplus_0_l; trivial. -Qed. - -Notation Rset := (Eqsth R). -Notation Rext := (Eq_ext Rplus Rmult Ropp). - -Lemma Rlt_0_2 : 0 < 2. -Proof. -apply Rlt_trans with (0 + 1). - apply Rlt_n_Sn. - rewrite Rplus_comm. - apply Rplus_lt_compat_l. - replace R1 with (0 + 1). - apply Rlt_n_Sn. - apply Rplus_0_l. -Qed. - -Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. -unfold Rgt. -induction x; simpl; intros. - apply Rlt_trans with (1 + 0). - rewrite Rplus_comm. - apply Rlt_n_Sn. - apply Rplus_lt_compat_l. - rewrite <- (Rmul_0_l Rset Rext RTheory 2). - rewrite Rmult_comm. - apply Rmult_lt_compat_l. - apply Rlt_0_2. - trivial. - rewrite <- (Rmul_0_l Rset Rext RTheory 2). - rewrite Rmult_comm. - apply Rmult_lt_compat_l. - apply Rlt_0_2. - trivial. - replace 1 with (0 + 1). - apply Rlt_n_Sn. - apply Rplus_0_l. -Qed. - - -Lemma Rgen_phiPOS_not_0 : - forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. -red; intros. -specialize (Rgen_phiPOS x). -rewrite H; intro. -apply (Rlt_asym 0 0); trivial. -Qed. - -Lemma Zeq_bool_complete : forall x y, - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> - Zeq_bool x y = true. -Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. - -Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. -Proof. - intros x n; elim n; simpl; auto with real. - intros n0 H' m; rewrite H'; auto with real. -Qed. - -Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow. -Proof. - constructor. destruct n. reflexivity. - simpl. induction p. - - rewrite Pos2Nat.inj_xI. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - - rewrite Pos2Nat.inj_xO. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. - - simpl. rewrite Rmult_comm;apply Rmult_1_l. -Qed. - -Ltac Rpow_tac t := - match isnatcst t with - | false => constr:(InitialRing.NotConstant) - | _ => constr:(N.of_nat t) - end. - -Ltac IZR_tac t := - match t with - | R0 => constr:(0%Z) - | R1 => constr:(1%Z) - | IZR (Z.pow_pos 10 ?p) => - match isPcst p with - | true => constr:(Z.pow_pos 10 p) - | _ => constr:(InitialRing.NotConstant) - end - | IZR ?u => - match isZcst u with - | true => u - | _ => constr:(InitialRing.NotConstant) - end - | _ => constr:(InitialRing.NotConstant) - end. - -Add Field RField : Rfield - (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v deleted file mode 100644 index 35e308565f..0000000000 --- a/plugins/setoid_ring/Ring.v +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Bool. -Require Export Ring_theory. -Require Export Ring_base. -Require Export InitialRing. -Require Export Ring_tac. - -Lemma BoolTheory : - ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)). -split; simpl. -destruct x; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. -reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. -reflexivity. -destruct x; reflexivity. -Qed. - -Definition bool_eq (b1 b2:bool) := - if b1 then b2 else negb b2. - -Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. -destruct b1; destruct b2; auto. -Qed. - -Ltac bool_cst t := - let t := eval hnf in t in - match t with - true => constr:(true) - | false => constr:(false) - | _ => constr:(NotConstant) - end. - -Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v deleted file mode 100644 index 36e7890fbb..0000000000 --- a/plugins/setoid_ring/Ring_base.v +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* This module gathers the necessary base to build an instance of the - ring tactic. Abstract rings need more theory, depending on - ZArith_base. *) - -Declare ML Module "newring_plugin". -Require Export Ring_theory. -Require Export Ring_tac. -Require Import InitialRing. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v deleted file mode 100644 index 092114ff0b..0000000000 --- a/plugins/setoid_ring/Ring_polynom.v +++ /dev/null @@ -1,1509 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -Set Implicit Arguments. -Require Import Setoid Morphisms. -Require Import BinList BinPos BinNat BinInt. -Require Export Ring_theory. -Local Open Scope positive_scope. -Import RingSyntax. -(* Set Universe Polymorphism. *) - -Section MakeRingPol. - - (* Ring elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Equivalence req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - (* division is ok *) - Variable cdiv: C -> C -> C * C. - Variable div_th: div_theory req cadd cmul phi cdiv. - - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - Infix "==" := req. - Infix "^" := (pow_pos rmul). - - (* C notations *) - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-! " := csub. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Morphism radd with signature (req ==> req ==> req) as radd_ext. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext. - Proof. exact (Ropp_ext Reqe). Qed. - - Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. - Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. - - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - Ltac add_permut_rec t := - match t with - | ?x + ?y => add_permut_rec y || add_permut_rec x - | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] - end. - - Ltac add_permut := - repeat (reflexivity || - match goal with |- ?t == _ => add_permut_rec t end). - - Ltac mul_permut_rec t := - match t with - | ?x * ?y => mul_permut_rec y || mul_permut_rec x - | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] - end. - - Ltac mul_permut := - repeat (reflexivity || - match goal with |- ?t == _ => mul_permut_rec t end). - - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match j ?= j' with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match i ?= i' with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Infix "?==" := Peq. - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj (j + j') Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P:= - match j with - | xH => P - | xO j => Pinj (Pos.pred_double j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pos.pred_double j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pos.pred_double j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match Z.pos_sub i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Infix "++" := Padd. - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match Z.pos_sub i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Infix "--" := Psub. - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match Z.pos_sub j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - - Infix "**" := Pmul. - - (** Monomial **) - - (** A monomial is X1^k1...Xi^ki. Its representation - is a simplified version of the polynomial representation: - - - [mon0] correspond to the polynom [P1]. - - [(zmon j M)] corresponds to [(Pinj j ...)], - i.e. skip j variable indices. - - [(vmon i M)] is X^i*M with X the current variable, - its corresponds to (PX P1 i ...)] - *) - - Inductive Mon: Set := - | mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Pos.pred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := - match P with - | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) - | Pinj j1 P1 => - let (R,S) := CFactor P1 c in - (mkPinj j1 R, mkPinj j1 S) - | PX P1 i Q1 => - let (R1, S1) := CFactor P1 c in - let (R2, S2) := CFactor Q1 c in - (mkPX R1 i R2, mkPX S1 i S2) - end. - - Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := - match P, M with - _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match j1 ?= j2 with - Eq => let (R,S) := MFactor P1 c M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 c M in - let (R2, S2) := MFactor Q1 c M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match i ?= j with - Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := - let (c,M1) := cM1 in - let (Q1,R1) := MFactor P1 c M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Local Notation hd := (List.hd 0). - - Fixpoint Pphi(l:list R) (P:Pol) : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - - Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l. - Infix "===" := Pequiv (at level 70, no associativity). - - Instance Pequiv_eq : Equivalence Pequiv. - Proof. - unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity]. - Qed. - - Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi. - Proof. - now intros l l' <- P Q H. - Qed. - - Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj. - Proof. - intros i j <- P P' HP l. simpl. now rewrite HP. - Qed. - - Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX. - Proof. - intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ. - Qed. - - (** Evaluation of a monomial towards R *) - - Fixpoint Mphi(l:list R) (M: Mon) : R := - match M with - | mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i - end. - - Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). - - (** Proofs *) - - Ltac destr_pos_sub := - match goal with |- context [Z.pos_sub ?x ?y] => - generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) - end. - - Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). - Proof. rewrite Pos.add_comm. apply jump_add. Qed. - - Lemma Peq_ok P P' : (P ?== P') = true -> P === P'. - Proof. - unfold Pequiv. - revert P';induction P;destruct P';simpl; intros H l; try easy. - - now apply (morph_eq CRmorph). - - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - now rewrite IHP. - - specialize (IHP1 P'1); specialize (IHP2 P'2). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. - destruct (P2 ?== P'1); [|easy]. - rewrite H in *. - now rewrite IHP1, IHP2. - Qed. - - Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P'). - Proof. - generalize (Peq_ok P P'). destruct (P ?== P'); auto. - Qed. - - Lemma Pphi0 l : P0@l == 0. - Proof. - simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 l : P1@l == 1. - Proof. - simpl;apply (morph1 CRmorph). - Qed. - - Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). - Proof. - destruct P;simpl;rsimpl. - now rewrite jump_add'. - Qed. - - Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj. - Proof. - intros i j <- P Q H l. now rewrite !mkPinj_ok. - Qed. - - Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. - Proof. - rewrite Pos.add_comm. - apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). - Qed. - - Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). - Proof. - generalize (morph_eq CRmorph c c'). - destruct (c ?=! c'); auto. - Qed. - - Lemma mkPX_ok l P i Q : - (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). - Proof. - unfold mkPX. destruct P. - - case ceqb_spec; intros H; simpl; try reflexivity. - rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. - - reflexivity. - - case Peq_spec; intros H; simpl; try reflexivity. - rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. - Qed. - - Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX. - Proof. - intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ. - Qed. - - Hint Rewrite - Pphi0 - Pphi1 - mkPinj_ok - mkPX_ok - (morph0 CRmorph) - (morph1 CRmorph) - (morph0 CRmorph) - (morph_add CRmorph) - (morph_mul CRmorph) - (morph_sub CRmorph) - (morph_opp CRmorph) - : Esimpl. - - (* Quicker than autorewrite with Esimpl :-) *) - Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. - - Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. - Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. - Proof. - revert l;induction P;simpl;intros. - - Esimpl. - - rewrite IHP;rsimpl. - - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. - Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. - Qed. - - Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. - Proof. - unfold PmulC. - case ceqb_spec; intros H. - - rewrite H; Esimpl. - - case ceqb_spec; intros H'. - + rewrite H'; Esimpl. - + apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok P l : (--P)@l == - P@l. - Proof. - revert l;induction P;simpl;intros. - - Esimpl. - - apply IHP. - - rewrite IHP1, IHP2;rsimpl. - Qed. - - Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. - - Lemma PaddX_ok P' P k l : - (forall P l, (P++P')@l == P@l + P'@l) -> - (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. - Proof. - intros IHP'. - revert k l. induction P;simpl;intros. - - add_permut. - - destruct p; simpl; - rewrite ?jump_pred_double; add_permut. - - destr_pos_sub; intros ->; Esimpl. - + rewrite IHP';rsimpl. add_permut. - + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. - + rewrite IHP1, pow_pos_add;rsimpl. add_permut. - Qed. - - Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. - Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. - + Esimpl; add_permut. - + destr_pos_sub; intros ->;Esimpl. - * now rewrite IHP'. - * rewrite IHP';Esimpl. now rewrite jump_add'. - * rewrite IHP. now rewrite jump_add'. - + destruct p0;simpl. - * rewrite IHP2;simpl. rsimpl. - * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. - * rewrite IHP'. rsimpl. - - destruct P;simpl. - + Esimpl. add_permut. - + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. - * rsimpl. add_permut. - * rewrite jump_pred_double. rsimpl. add_permut. - * rsimpl. add_permut. - + destr_pos_sub; intros ->; Esimpl. - * rewrite IHP'1, IHP'2;rsimpl. add_permut. - * rewrite IHP'1, IHP'2;simpl;Esimpl. - rewrite pow_pos_add;rsimpl. add_permut. - * rewrite PaddX_ok by trivial; rsimpl. - rewrite IHP'2, pow_pos_add; rsimpl. add_permut. - Qed. - - Lemma Psub_opp P' P : P -- P' === P ++ (--P'). - Proof. - revert P; induction P'; simpl; intros. - - intro l; Esimpl. - - revert p; induction P; simpl; intros; try reflexivity. - + destr_pos_sub; intros ->; now apply mkPinj_ext. - + destruct p0; now apply PX_ext. - - destruct P; simpl; try reflexivity. - + destruct p0; now apply PX_ext. - + destr_pos_sub; intros ->; apply mkPX_ext; auto. - revert p1. induction P2; simpl; intros; try reflexivity. - destr_pos_sub; intros ->; now apply mkPX_ext. - Qed. - - Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. - Proof. - rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl. - Qed. - - Lemma PmulI_ok P' : - (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> - forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - intros IHP'. - induction P;simpl;intros. - - Esimpl; mul_permut. - - destr_pos_sub; intros ->;Esimpl. - + now rewrite IHP'. - + now rewrite IHP', jump_add'. - + now rewrite IHP, jump_add'. - - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. - + f_equiv. mul_permut. - + rewrite jump_pred_double. f_equiv. mul_permut. - + rewrite IHP'. f_equiv. mul_permut. - Qed. - - Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. - Proof. - revert P l;induction P';simpl;intros. - - apply PmulC_ok. - - apply PmulI_ok;trivial. - - destruct P. - + rewrite (ARmul_comm ARth). Esimpl. - + Esimpl. f_equiv. rewrite IHP'1; Esimpl. - destruct p0;rewrite IHP'2;Esimpl. - rewrite jump_pred_double; Esimpl. - + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, - !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. - add_permut; f_equiv; mul_permut. - Qed. - - Lemma mkZmon_ok M j l : - (mkZmon j M) @@ l == (zmon j M) @@ l. - Proof. - destruct M; simpl; rsimpl. - Qed. - - Lemma zmon_pred_ok M j l : - (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. - Proof. - destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. - rewrite jump_pred_double; rsimpl. - Qed. - - Lemma mkVmon_ok M i l : - (mkVmon i M)@@l == M@@l * (hd l)^i. - Proof. - destruct M;simpl;intros;rsimpl. - - rewrite zmon_pred_ok;simpl;rsimpl. - - rewrite pow_pos_add;rsimpl. - Qed. - - Ltac destr_factor := match goal with - | H : context [CFactor ?P _] |- context [CFactor ?P ?c] => - destruct (CFactor P c); destr_factor; rewrite H; clear H - | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] => - specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H - | _ => idtac - end. - - Lemma Mcphi_ok P c l : - let (Q,R) := CFactor P c in - P@l == Q@l + [c] * R@l. - Proof. - revert l. - induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := (div_eucl_th div_th) c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - - destr_factor. Esimpl. - - destr_factor. Esimpl. add_permut. - Qed. - - Lemma Mphi_ok P (cM: C * Mon) l : - let (c,M) := cM in - let (Q,R) := MFactor P c M in - P@l == Q@l + [c] * M@@l * R@l. - Proof. - destruct cM as (c,M). revert M l. - induction P; destruct M; intros l; simpl; auto; - try (case ceqb_spec; intro He); - try (case Pos.compare_spec; intros He); - rewrite ?He; - destr_factor; simpl; Esimpl. - - assert (H := div_eucl_th div_th c0 c). - destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - - now rewrite <- jump_add, Pos.sub_add. - - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c). - destr_factor. Esimpl. add_permut. - - rewrite zmon_pred_ok. simpl. add_permut. - - rewrite mkZmon_ok. simpl. add_permut. mul_permut. - - add_permut. mul_permut. - rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. - - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut. - rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. - Qed. - - Lemma POneSubst_ok P1 cM1 P2 P3 l : - POneSubst P1 cM1 P2 = Some P3 -> - [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. - Proof. - destruct cM1 as (cc,M1). - unfold POneSubst. - assert (H := Mphi_ok P1 (cc, M1) l). simpl in H. - destruct MFactor as (R1,S1); simpl. rewrite H. clear H. - intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). - - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. - - revert EQ. destruct S1; try now injection 1. - case ceqb_spec; now inversion 2. - Qed. - - Lemma PNSubst1_ok n P1 cM1 P2 l : - [fst cM1] * (snd cM1)@@l == P2@l -> - P1@l == (PNSubst1 P1 cM1 P2 n)@l. - Proof. - revert P1. induction n; simpl; intros P1; - generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; - intros; rewrite <- ?IHn; auto; reflexivity. - Qed. - - Lemma PNSubst_ok n P1 cM1 P2 l P3 : - PNSubst P1 cM1 P2 n = Some P3 -> - [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. - Proof. - unfold PNSubst. - assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate. - destruct n; inversion_clear 1. - intros. rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop := - match LM1 with - | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == P2@l) /\ MPcond LM2 l - | _ => True - end. - - Lemma PSubstL1_ok n LM1 P1 l : - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. - - reflexivity. - - rewrite <- IH by intuition; now apply PNSubst1_ok. - Qed. - - Lemma PSubstL_ok n LM1 P1 P2 l : - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - - discriminate. - - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. - * now apply IH. - Qed. - - Lemma PNSubstL_ok m n LM1 P1 l : - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - revert LM1 P1. induction m; simpl; intros; - assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; - auto; try reflexivity. - rewrite <- IHm; auto. - Qed. - - (** Definition of polynomial expressions *) - - Inductive PExpr : Type := - | PEO : PExpr - | PEI : PExpr - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - - Register PExpr as plugins.setoid_ring.pexpr. - Register PEc as plugins.setoid_ring.const. - Register PEX as plugins.setoid_ring.var. - Register PEadd as plugins.setoid_ring.add. - Register PEsub as plugins.setoid_ring.sub. - Register PEmul as plugins.setoid_ring.mul. - Register PEopp as plugins.setoid_ring.opp. - Register PEpow as plugins.setoid_ring.pow. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := - match pe with - | PEO => rO - | PEI => rI - | PEc c => phi c - | PEX j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - -Strategy expand [PEeval]. - - (** Correctness proofs *) - - Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - - now rewrite <-jump_tl, nth_jump. - - now rewrite <- nth_jump, nth_pred_double. - Qed. - - Hint Rewrite Padd_ok Psub_ok : Esimpl. - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := - match p with - | xH => subst_l (res ** P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok l : - (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros subst_l_ok res P p. revert res. - induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; - mul_permut. - Qed. - - Lemma Ppow_N_ok l : - (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. - destruct n;simpl. - - reflexivity. - - rewrite Ppow_pos_ok by trivial. Esimpl. - Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (C*Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (P1 ** P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEO => Pc cO - | PEI => Pc cI - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) - | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) - | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) - | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) - | PEopp pe1 => -- (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (** Internally, [norm_aux] is expanded in a large number of cases. - To speed-up proofs, we use an alternative definition. *) - - Definition get_PEopp pe := - match pe with - | PEopp pe' => Some pe' - | _ => None - end. - - Lemma norm_aux_PEadd pe1 pe2 : - norm_aux (PEadd pe1 pe2) = - match get_PEopp pe1, get_PEopp pe2 with - | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') - | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') - | None, None => (norm_aux pe1) ++ (norm_aux pe2) - end. - Proof. - simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | | | reflexivity | ]; - destruct pe2; simpl get_PEopp; reflexivity. - Qed. - - Lemma norm_aux_PEopp pe : - match get_PEopp pe with - | Some pe' => norm_aux pe = -- (norm_aux pe') - | None => True - end. - Proof. - now destruct pe. - Qed. - - Arguments norm_aux !pe : simpl nomatch. - - Lemma norm_aux_spec l pe : - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe; cbn. - - now rewrite (morph0 CRmorph). - - now rewrite (morph1 CRmorph). - - reflexivity. - - apply mkX_ok. - - rewrite IHpe1, IHpe2. - assert (H1 := norm_aux_PEopp pe1). - assert (H2 := norm_aux_PEopp pe2). - rewrite norm_aux_PEadd. - do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. - - rewrite IHpe1, IHpe2. Esimpl. - - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - - rewrite IHpe. Esimpl. - - rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. - induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. - Qed. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;unfold norm_subst. - unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. - Qed. - - End NORM_SUBST_REC. - - Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := - match lpe with - | nil => True - | (me,pe)::lpe => - match lpe with - | nil => PEeval l me == PEeval l pe - | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe - end - end. - - Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := - match P with - | Pc c => if (c ?=! cO) then None else Some (c, mon0) - | Pinj j P => - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkZmon j m) - end - | PX P i Q => - if Peq Q P0 then - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkVmon i m) - end - else None - end. - - Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := - match lpe with - | nil => nil - | (me,pe)::lpe => - match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe - end - end. - - Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> - forall l, [fst m] * Mphi l (snd m) == P@l. - Proof. - induction P;simpl;intros;Esimpl. - assert (H1 := (morph_eq CRmorph) c cO). - destruct (c ?=! cO). - discriminate. - inversion H;trivial;Esimpl. - generalize H;clear H;case_eq (mon_of_pol P). - intros (c1,P2) H0 H1; inversion H1; Esimpl. - generalize (IHP (c1, P2) H0 (jump p l)). - rewrite mkZmon_ok;simpl;auto. - intros; discriminate. - generalize H;clear H;change match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end with (P3 ?== P0). - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - case_eq (mon_of_pol P2);try intros (cc, pp); intros. - inversion H1. - simpl. - rewrite mkVmon_ok;simpl. - rewrite H;trivial;Esimpl. - generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. - discriminate. - intros;discriminate. - Qed. - - Lemma interp_PElist_ok : forall l lpe, - interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. - Proof. - induction lpe;simpl. trivial. - destruct a;simpl;intros. - assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); - destruct (mon_of_pol (norm_subst 0 nil p)). - split. - rewrite <- norm_subst_spec by exact I. - destruct lpe;try destruct H;rewrite <- H; - rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. - Qed. - - Lemma norm_subst_ok : forall n l lpe pe, - interp_PElist l lpe -> - PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. - Proof. - intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. - Qed. - - Lemma ring_correct : forall n l lpe pe1 pe2, - interp_PElist l lpe -> - (let lmp := mk_monpol_list lpe in - norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> - PEeval l pe1 == PEeval l pe2. - Proof. - simpl;intros. - do 2 (rewrite (norm_subst_ok n l lpe);trivial). - apply Peq_ok;trivial. - Qed. - - - - (** Generic evaluation of polynomial towards R avoiding parenthesis *) - Variable get_sign : C -> option C. - Variable get_sign_spec : sign_theory copp ceqb get_sign. - - - Section EVALUATION. - - (* [mkpow x p] = x^p *) - Variable mkpow : R -> positive -> R. - (* [mkpow x p] = -(x^p) *) - Variable mkopp_pow : R -> positive -> R. - (* [mkmult_pow r x p] = r * x^p *) - Variable mkmult_pow : R -> R -> positive -> R. - - Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := - match lm with - | nil => r - | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t - end. - - Definition mkmult1 lm := - match lm with - | nil => 1 - | cons (x,p) t => mkmult_rec (mkpow x p) t - end. - - Definition mkmultm1 lm := - match lm with - | nil => ropp rI - | cons (x,p) t => mkmult_rec (mkopp_pow x p) t - end. - - Definition mkmult_c_pos c lm := - if c ?=! cI then mkmult1 (rev' lm) - else mkmult_rec [c] (rev' lm). - - Definition mkmult_c c lm := - match get_sign c with - | None => mkmult_c_pos c lm - | Some c' => - if c' ?=! cI then mkmultm1 (rev' lm) - else mkmult_rec [c] (rev' lm) - end. - - Definition mkadd_mult rP c lm := - match get_sign c with - | None => rP + mkmult_c_pos c lm - | Some c' => rP - mkmult_c_pos c' lm - end. - - Definition add_pow_list (r:R) n l := - match n with - | N0 => l - | Npos p => (r,p)::l - end. - - Fixpoint add_mult_dev - (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := - match P with - | Pc c => - let lm := add_pow_list (hd fv) n lm in - mkadd_mult rP c lm - | Pinj j Q => - add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm) - | PX P i Q => - let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in - if Q ?== P0 then rP - else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm) - end. - - Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) - (lm:list (R*positive)) {struct P} : R := - (* P@l * (hd 0 l)^n * lm *) - match P with - | Pc c => mkmult_c c (add_pow_list (hd fv) n lm) - | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm) - | PX P i Q => - let rP := mult_dev P fv (N.add (Npos i) n) lm in - if Q ?== P0 then rP - else - let lmq := add_pow_list (hd fv) n lm in - add_mult_dev rP Q (tail fv) N0 lmq - end. - - Definition Pphi_avoid fv P := mult_dev P fv N0 nil. - - Fixpoint r_list_pow (l:list (R*positive)) : R := - match l with - | nil => rI - | cons (r,p) l => pow_pos rmul r p * r_list_pow l - end. - - Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. - Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). - Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. - - Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. - Proof. - induction lm;intros;simpl;Esimpl. - destruct a as (x,p);Esimpl. - rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. - Qed. - - Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. - Proof. - destruct lm;simpl;Esimpl. - destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. - Qed. - - Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. - Proof. - destruct lm;simpl;Esimpl. - destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. - Qed. - - Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. - Proof. - assert - (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). - induction l;intros;simpl;Esimpl. - destruct a;rewrite IHl;Esimpl. - rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. - intros;unfold rev'. rewrite H;simpl;Esimpl. - Qed. - - Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. - Proof. - intros;unfold mkmult_c_pos;simpl. - assert (H := (morph_eq CRmorph) c cI). - rewrite <- r_list_pow_rev; destruct (c ?=! cI). - rewrite H;trivial;Esimpl. - apply mkmult1_ok. apply mkmult_rec_ok. - Qed. - - Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. - Proof. - intros;unfold mkmult_c;simpl. - case_eq (get_sign c);intros. - assert (H1 := (morph_eq CRmorph) c0 cI). - destruct (c0 ?=! cI). - rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. - rewrite <- r_list_pow_rev;trivial;Esimpl. - apply mkmultm1_ok. - rewrite <- r_list_pow_rev; apply mkmult_rec_ok. - apply mkmult_c_pos_ok. -Qed. - - Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. - Proof. - intros;unfold mkadd_mult. - case_eq (get_sign c);intros. - rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. - rewrite mkmult_c_pos_ok;Esimpl. - rewrite mkmult_c_pos_ok;Esimpl. - Qed. - - Lemma add_pow_list_ok : - forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. - Proof. - destruct n;simpl;intros;Esimpl. - Qed. - - Lemma add_mult_dev_ok : forall P rP fv n lm, - add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. - Proof. - induction P;simpl;intros. - rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. - rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (N.add (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H eq_refl). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut. mul_permut. - rewrite IHP2. - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut. mul_permut. - Qed. - - Lemma mult_dev_ok : forall P fv n lm, - mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. - Proof. - induction P;simpl;intros;Esimpl. - rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. - rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (N.add (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H eq_refl). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - mul_permut. - rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. - destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. - add_permut; mul_permut. - Qed. - - Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. - Proof. - unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. - Qed. - - End EVALUATION. - - Definition Pphi_pow := - let mkpow x p := - match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in - let mkopp_pow x p := ropp (mkpow x p) in - let mkmult_pow r x p := rmul r (mkpow x p) in - Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma local_mkpow_ok r p : - match p with - | xI _ => rpow r (Cp_phi (Npos p)) - | xO _ => rpow r (Cp_phi (Npos p)) - | 1 => r - end == pow_pos rmul r p. - Proof. destruct p; now rewrite ?(rpow_pow_N pow_th). Qed. - - Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. - Proof. - unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros; - now rewrite ?local_mkpow_ok. - Qed. - - Lemma ring_rw_pow_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_pow l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_pow_ok, <- Heq2, <- Heq1. - apply norm_subst_ok. trivial. - Qed. - - Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := - match p with - | xH => r*x - | xO p => mkmult_pow (mkmult_pow r x p) x p - | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p - end. - - Definition mkpow x p := - match p with - | xH => x - | xO p => mkmult_pow x x (Pos.pred_double p) - | xI p => mkmult_pow x x (xO p) - end. - - Definition mkopp_pow x p := - match p with - | xH => -x - | xO p => mkmult_pow (-x) x (Pos.pred_double p) - | xI p => mkmult_pow (-x) x (xO p) - end. - - Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. - Proof. - revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl. - Qed. - - Lemma mkpow_ok p x : mkpow x p == x^p. - Proof. - destruct p;simpl;intros;Esimpl. - - rewrite !mkmult_pow_ok;Esimpl. - - rewrite mkmult_pow_ok;Esimpl. - change x with (x^1) at 1. - now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. - Qed. - - Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p. - Proof. - destruct p;simpl;intros;Esimpl. - - rewrite !mkmult_pow_ok;Esimpl. - - rewrite mkmult_pow_ok;Esimpl. - change x with (x^1) at 1. - now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. - Qed. - - Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. - Proof. - unfold Pphi_dev;intros;apply Pphi_avoid_ok. - - intros;apply mkpow_ok. - - intros;apply mkopp_pow_ok. - - intros;apply mkmult_pow_ok. - Qed. - - Lemma ring_rw_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_dev l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. - apply norm_subst_ok. trivial. - Qed. - -End MakeRingPol. - -Arguments PEO {C}. -Arguments PEI {C}. diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v deleted file mode 100644 index 0a14c0ee5c..0000000000 --- a/plugins/setoid_ring/Ring_tac.v +++ /dev/null @@ -1,472 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinPos. -Require Import Ring_polynom. -Require Import BinList. -Require Export ListTactics. -Require Import InitialRing. -Declare ML Module "newring_plugin". - - -(* adds a definition t' on the normal form of t and an hypothesis id - stating that t = t' (tries to produces a proof as small as possible) *) -Ltac compute_assertion eqn t' t := - let nft := eval vm_compute in t in - pose (t' := nft); - assert (eqn : t = t'); - [vm_cast_no_check (eq_refl t')|idtac]. - -Ltac relation_carrier req := - let ty := type of req in - match eval hnf in ty with - ?R -> _ => R - | _ => fail 1000 "Equality has no relation type" - end. - -Ltac Get_goal := match goal with [|- ?G] => G end. - -(********************************************************************) -(* Tacticals to build reflexive tactics *) - -Ltac OnEquation req := - match goal with - | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => (fun _ => fail "Goal is not an equation (of expected equality)") - end. - -Ltac OnEquationHyp req h := - match type of h with - | req ?lhs ?rhs => fun f => f lhs rhs - | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)") - end. - -(* Note: auxiliary subgoals in reverse order *) -Ltac OnMainSubgoal H ty := - match ty with - | _ -> ?ty' => - let subtac := OnMainSubgoal H ty' in - fun kont => lapply H; [clear H; intro H; subtac kont | idtac] - | _ => (fun kont => kont()) - end. - -(* A generic pattern to have reflexive tactics do some computation: - lemmas of the form [forall x', x=x' -> P(x')] are understood as: - compute the normal form of x, instantiate x' with it, prove - hypothesis x=x' with vm_compute and reflexivity, and pass the - instantiated lemma to the continuation. - *) -Ltac ProveLemmaHyp lemma := - match type of lemma with - forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in - let H := fresh "res_eq" in - compute_assertion H x' x; - let lemma' := constr:(lemma x' H) in - kont lemma'; - (clear H||idtac"ProveLemmaHyp: cleanup failed"); - subst x') - | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form") - end. - -Ltac ProveLemmaHyps lemma := - match type of lemma with - forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in - let H := fresh "res_eq" in - compute_assertion H x' x; - let lemma' := constr:(lemma x' H) in - ProveLemmaHyps lemma' kont; - (clear H||idtac"ProveLemmaHyps: cleanup failed"); - subst x') - | _ => (fun kont => kont lemma) - end. - -(* -Ltac ProveLemmaHyps lemma := (* expects a continuation *) - let try_step := ProveLemmaHyp lemma in - (fun kont => - try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) || - kont lemma). -*) -Ltac ApplyLemmaThen lemma expr kont := - let lem := constr:(lemma expr) in - ProveLemmaHyp lem ltac:(fun lem' => - let Heq := fresh "thm" in - assert (Heq:=lem'); - OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq); - (clear Heq||idtac"ApplyLemmaThen: cleanup failed")). -(* -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := - let pe := - match type of (lemma expr) with - forall pe', ?pe = pe' -> _ => pe - | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" - end in - let pe' := fresh "expr_nf" in - let nf_pe := fresh "pe_eq" in - compute_assertion nf_pe pe' pe; - let Heq := fresh "thm" in - (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma"); - clear nf_pe; - OnMainSubgoal Heq ltac:(type of Heq) - ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)). -*) -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac := - ApplyLemmaThen lemma expr - ltac:(fun lemma' => try tac lemma'; CONT_tac()). - -(* General scheme of reflexive tactics using of correctness lemma - that involves normalisation of one expression - - [FV_tac term fv] is a tactic that adds the atomic expressions - of [term] into [fv] - - [SYN_tac term fv] reifies [term] given the list of atomic expressions - - [LEMMA_tac fv kont] computes the correctness lemma and passes it to - continuation kont - - [MAIN_tac H] process H which is the conclusion of the correctness lemma - instantiated with each reified term - - [fv] is the initial value of atomic expressions (to be completed by - the reification of the terms - - [terms] the list (a constr of type list) of terms to reify and process. - *) -Ltac ReflexiveRewriteTactic - FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := - (* extend the atom list *) - let fv := list_fold_left FV_tac fv terms in - let RW_tac lemma := - let fcons term CONT_tac := - let expr := SYN_tac term fv in - let main H := - match type of H with - | (?req _ ?rhs) => change (req term rhs) in H - end; - MAIN_tac H in - (ApplyLemmaThenAndCont lemma expr main CONT_tac) in - (* rewrite steps *) - lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in - LEMMA_tac fv RW_tac. - -(********************************************************) - -Ltac FV_hypo_tac mkFV req lH := - let R := relation_carrier req in - let FV_hypo_l_tac h := - match h with @mkhypo (req ?pe _) _ => mkFV pe end in - let FV_hypo_r_tac h := - match h with @mkhypo (req _ ?pe) _ => mkFV pe end in - let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in - list_fold_right FV_hypo_r_tac fv lH. - -Ltac mkHyp_tac C req Reify lH := - let mkHyp h res := - match h with - | @mkhypo (req ?r1 ?r2) _ => - let pe1 := Reify r1 in - let pe2 := Reify r2 in - constr:(cons (pe1,pe2) res) - | _ => fail 1 "hypothesis is not a ring equality" - end in - list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. - -Ltac proofHyp_tac lH := - let get_proof h := - match h with - | @mkhypo _ ?p => p - end in - let rec bh l := - match l with - | nil => constr:(I) - | cons ?h nil => get_proof h - | cons ?h ?tl => - let l := get_proof h in - let r := bh tl in - constr:(conj l r) - end in - bh lH. - -Ltac get_MonPol lemma := - match type of lemma with - | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] => - constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb) - | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)" - end. - -(********************************************************) - -(* Building the atom list of a ring expression *) -(* We do not assume that Cst recognizes the rO and rI terms as constants, as *) -(* the tactic could be used to discriminate occurrences of an opaque *) -(* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac FV Cst CstPow rO rI add mul sub opp pow t fv := - let rec TFV t fv := - let f := - match Cst t with - | NotConstant => - match t with - | rO => fun _ => fv - | rI => fun _ => fv - | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => fun _ => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => fun _ => AddFvTail t fv - | _ => fun _ => TFV t1 fv - end - | _ => fun _ => AddFvTail t fv - end - | _ => fun _ => fv - end in - f() - in TFV t fv. - - (* syntaxification of ring expressions *) - (* We do not assume that Cst recognizes the rO and rI terms as constants, as *) - (* the tactic could be used to discriminate occurrences of an opaque *) - (* constant phi, with (phi 0) not convertible to 0 for instance *) -Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv := - let rec mkP t := - let f := - match Cst t with - | InitialRing.NotConstant => - match t with - | rO => - fun _ => constr:(@PEO C) - | rI => - fun _ => constr:(@PEI C) - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEadd C e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEmul C e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(@PEsub C e1 e2) - | (ropp ?t1) => - fun _ => - let e1 := mkP t1 in constr:(@PEopp C e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - fun _ => let p := Find_at t fv in constr:(PEX C p) - | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c) - end - | _ => - fun _ => let p := Find_at t fv in constr:(PEX C p) - end - | ?c => fun _ => constr:(@PEc C c) - end in - f () - in mkP t. - -(* packaging the ring structure *) - -Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post := - let RNG := - match type of lemma1 with - | context - [@PEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => - (fun proj => proj - cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - end in - F RNG. - -Ltac get_Carrier RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - R). - -Ltac get_Eq RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - req). - -Ltac get_Pre RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - pre). - -Ltac get_Post RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - post). - -Ltac get_NormLemma RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - lemma1). - -Ltac get_SimplifyLemma RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - lemma2). - -Ltac get_RingFV RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - FV cst_tac pow_tac r0 r1 add mul sub opp pow). - -Ltac get_RingMeta RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow). - -Ltac get_RingHypTac RNG := - RNG ltac:(fun cst_tac pow_tac pre post - R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 => - let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in - fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). - -(* ring tactics *) - -Definition ring_subst_niter := (10*10*10)%nat. - -Ltac Ring RNG lemma lH := - let req := get_Eq RNG in - OnEquation req ltac:(fun lhs rhs => - let mkFV := get_RingFV RNG in - let mkPol := get_RingMeta RNG in - let mkHyp := get_RingHypTac RNG in - let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let fv := mkFV lhs fv in - let fv := mkFV rhs fv in - check_fv fv; - let pe1 := mkPol lhs fv in - let pe2 := mkPol rhs fv in - let lpe := mkHyp fv lH in - let vlpe := fresh "hyp_list" in - let vfv := fresh "fv_list" in - pose (vlpe := lpe); - pose (vfv := fv); - (apply (lemma vfv vlpe pe1 pe2) - || fail "typing error while applying ring"); - [ ((let prh := proofHyp_tac lH in exact prh) - || idtac "can not automatically prove hypothesis :"; - [> idtac " maybe a left member of a hypothesis is not a monomial"..]) - | vm_compute; - (exact (eq_refl true) || fail "not a valid ring equation")]). - -Ltac Ring_norm_gen f RNG lemma lH rl := - let mkFV := get_RingFV RNG in - let mkPol := get_RingMeta RNG in - let mkHyp := get_RingHypTac RNG in - let mk_monpol := get_MonPol lemma in - let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let lemma_tac fv kont := - let lpe := mkHyp fv lH in - let vlpe := fresh "list_hyp" in - let vlmp := fresh "list_hyp_norm" in - let vlmp_eq := fresh "list_hyp_norm_eq" in - let prh := proofHyp_tac lH in - pose (vlpe := lpe); - compute_assertion vlmp_eq vlmp (mk_monpol vlpe); - let H := fresh "ring_lemma" in - (assert (H := lemma vlpe fv prh vlmp vlmp_eq) - || fail "type error when build the rewriting lemma"); - clear vlmp_eq; - kont H; - (clear H||idtac"Ring_norm_gen: cleanup failed"); - subst vlpe vlmp in - let simpl_ring H := (protect_fv "ring" in H; f H) in - ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl. - -Ltac Ring_gen RNG lH rl := - let lemma := get_NormLemma RNG in - get_Pre RNG (); - Ring RNG (lemma ring_subst_niter) lH. - -Tactic Notation (at level 0) "ring" := - let G := Get_goal in - ring_lookup (PackRing Ring_gen) [] G. - -Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := - let G := Get_goal in - ring_lookup (PackRing Ring_gen) [lH] G. - -(* Simplification *) - -Ltac Ring_simplify_gen f RNG lH rl := - let lemma := get_SimplifyLemma RNG in - let l := fresh "to_rewrite" in - pose (l:= rl); - generalize (eq_refl l); - unfold l at 2; - get_Pre RNG (); - let rl := - match goal with - | [|- l = ?RL -> _ ] => RL - | _ => fail 1 "ring_simplify anomaly: bad goal after pre" - end in - let Heq := fresh "Heq" in - intros Heq;clear Heq l; - Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; - get_Post RNG (). - -Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := - let G := Get_goal in - ring_lookup (PackRing Ring_simplify) [] rl G. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - ring_lookup (PackRing Ring_simplify) [lH] rl G. - -Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H; - ring_lookup (PackRing Ring_simplify) [] rl t; - (* - Correction of bug 1859: - we want to leave H at its initial position - this is obtained by adding a copy of H (H'), - move it just after H, remove H and finally - rename H into H' - *) - let H' := fresh "H" in - intro H'; - move H' after H; - clear H;rename H' into H; - unfold g;clear g. - -Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H; - ring_lookup (PackRing Ring_simplify) [lH] rl t; - (* - Correction of bug 1859: - we want to leave H at its initial position - this is obtained by adding a copy of H (H'), - move it just after H, remove H and finally - rename H into H' - *) - let H' := fresh "H" in - intro H'; - move H' after H; - clear H;rename H' into H; - unfold g;clear g. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v deleted file mode 100644 index dc45853458..0000000000 --- a/plugins/setoid_ring/Ring_theory.v +++ /dev/null @@ -1,619 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import Setoid Morphisms BinPos BinNat. - -Set Implicit Arguments. - -Module RingSyntax. -Reserved Notation "x ?=! y" (at level 70, no associativity). -Reserved Notation "x +! y " (at level 50, left associativity). -Reserved Notation "x -! y" (at level 50, left associativity). -Reserved Notation "x *! y" (at level 40, left associativity). -Reserved Notation "-! x" (at level 35, right associativity). - -Reserved Notation "[ x ]" (at level 0). - -Reserved Notation "x ?== y" (at level 70, no associativity). -Reserved Notation "x -- y" (at level 50, left associativity). -Reserved Notation "x ** y" (at level 40, left associativity). -Reserved Notation "-- x" (at level 35, right associativity). - -Reserved Notation "x == y" (at level 70, no associativity). -End RingSyntax. -Import RingSyntax. - -(* Set Universe Polymorphism. *) - -Section Power. - Variable R:Type. - Variable rI : R. - Variable rmul : R -> R -> R. - Variable req : R -> R -> Prop. - Variable Rsth : Equivalence req. - Infix "*" := rmul. - Infix "==" := req. - - Hypothesis mul_ext : Proper (req ==> req ==> req) rmul. - Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. - - Fixpoint pow_pos (x:R) (i:positive) : R := - match i with - | xH => x - | xO i => let p := pow_pos x i in p * p - | xI i => let p := pow_pos x i in x * (p * p) - end. - - Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. - Proof. - induction j; simpl; rewrite <- ?mul_assoc. - - f_equiv. now do 2 (rewrite IHj, mul_assoc). - - now do 2 (rewrite IHj, mul_assoc). - - reflexivity. - Qed. - - Lemma pow_pos_succ x j : - pow_pos x (Pos.succ j) == x * pow_pos x j. - Proof. - induction j; simpl; try reflexivity. - rewrite IHj, <- mul_assoc; f_equiv. - now rewrite mul_assoc, pow_pos_swap, mul_assoc. - Qed. - - Lemma pow_pos_add x i j : - pow_pos x (i + j) == pow_pos x i * pow_pos x j. - Proof. - induction i using Pos.peano_ind. - - now rewrite Pos.add_1_l, pow_pos_succ. - - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. - Qed. - - Definition pow_N (x:R) (p:N) := - match p with - | N0 => rI - | Npos p => pow_pos x p - end. - - Definition id_phi_N (x:N) : N := x. - - Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n. - Proof. - reflexivity. - Qed. - -End Power. - -Section DEFINITIONS. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Infix "==" := req. Infix "+" := radd. Infix "*" := rmul. - Infix "-" := rsub. Notation "- x" := (ropp x). - - (** Semi Ring *) - Record semi_ring_theory : Prop := mk_srt { - SRadd_0_l : forall n, 0 + n == n; - SRadd_comm : forall n m, n + m == m + n ; - SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; - SRmul_1_l : forall n, 1*n == n; - SRmul_0_l : forall n, 0*n == 0; - SRmul_comm : forall n m, n*m == m*n; - SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; - SRdistr_l : forall n m p, (n + m)*p == n*p + m*p - }. - - (** Almost Ring *) -(*Almost ring are no ring : Ropp_def is missing **) - Record almost_ring_theory : Prop := mk_art { - ARadd_0_l : forall x, 0 + x == x; - ARadd_comm : forall x y, x + y == y + x; - ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; - ARmul_1_l : forall x, 1 * x == x; - ARmul_0_l : forall x, 0 * x == 0; - ARmul_comm : forall x y, x * y == y * x; - ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - ARopp_mul_l : forall x y, -(x * y) == -x * y; - ARopp_add : forall x y, -(x + y) == -x + -y; - ARsub_def : forall x y, x - y == x + -y - }. - - (** Ring *) - Record ring_theory : Prop := mk_rt { - Radd_0_l : forall x, 0 + x == x; - Radd_comm : forall x y, x + y == y + x; - Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; - Rmul_1_l : forall x, 1 * x == x; - Rmul_comm : forall x y, x * y == y * x; - Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - Rsub_def : forall x y, x - y == x + -y; - Ropp_def : forall x, x + (- x) == 0 - }. - - (** Equality is extensional *) - - Record sring_eq_ext : Prop := mk_seqe { - (* SRing operators are compatible with equality *) - SRadd_ext : Proper (req ==> req ==> req) radd; - SRmul_ext : Proper (req ==> req ==> req) rmul - }. - - Record ring_eq_ext : Prop := mk_reqe { - (* Ring operators are compatible with equality *) - Radd_ext : Proper (req ==> req ==> req) radd; - Rmul_ext : Proper (req ==> req ==> req) rmul; - Ropp_ext : Proper (req ==> req) ropp - }. - - (** Interpretation morphisms definition*) - Section MORPHISM. - Variable C:Type. - Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - (* [phi] est un morphisme de [C] dans [R] *) - Variable phi : C -> R. - Infix "+!" := cadd. Infix "-!" := csub. - Infix "*!" := cmul. Notation "-! x" := (copp x). - Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). - -(*for semi rings*) - Record semi_morph : Prop := mkRmorph { - Smorph0 : [cO] == 0; - Smorph1 : [cI] == 1; - Smorph_add : forall x y, [x +! y] == [x]+[y]; - Smorph_mul : forall x y, [x *! y] == [x]*[y]; - Smorph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - -(* for rings*) - Record ring_morph : Prop := mkmorph { - morph0 : [cO] == 0; - morph1 : [cI] == 1; - morph_add : forall x y, [x +! y] == [x]+[y]; - morph_sub : forall x y, [x -! y] == [x]-[y]; - morph_mul : forall x y, [x *! y] == [x]*[y]; - morph_opp : forall x, [-!x] == -[x]; - morph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - - Section SIGN. - Variable get_sign : C -> option C. - Record sign_theory : Prop := mksign_th { - sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true - }. - End SIGN. - - Definition get_sign_None (c:C) := @None C. - - Lemma get_sign_None_th : sign_theory get_sign_None. - Proof. constructor;intros;discriminate. Qed. - - Section DIV. - Variable cdiv: C -> C -> C*C. - Record div_theory : Prop := mkdiv_th { - div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] - }. - End DIV. - - End MORPHISM. - - (** Identity is a morphism *) - Variable Rsth : Equivalence req. - Variable reqb : R->R->bool. - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - Definition IDphi (x:R) := x. - Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. - Proof. - now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi). - Qed. - - (** Specification of the power function *) - Section POWER. - Variable Cpow : Type. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - - Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) - }. - - End POWER. - - Definition pow_N_th := - mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). - - -End DEFINITIONS. - -Section ALMOST_RING. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Infix "==" := req. Infix "+" := radd. Infix "* " := rmul. - - (** Leibniz equality leads to a setoid theory and is extensional*) - Lemma Eqsth : Equivalence (@eq R). - Proof. exact eq_equivalence. Qed. - - Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). - Proof. constructor;solve_proper. Qed. - - Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). - Proof. constructor;solve_proper. Qed. - - Variable Rsth : Equivalence req. - - Section SEMI_RING. - Variable SReqe : sring_eq_ext radd rmul req. - - Add Morphism radd with signature (req ==> req ==> req) as radd_ext1. - Proof. exact (SRadd_ext SReqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext1. - Proof. exact (SRmul_ext SReqe). Qed. - - Variable SRth : semi_ring_theory 0 1 radd rmul req. - - (** Every semi ring can be seen as an almost ring, by taking : - [-x = x] and [x - y = x + y] *) - Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). - - Definition SRsub x y := x + -y. Infix "-" := SRsub. - - Lemma SRopp_ext : forall x y, x == y -> -x == -y. - Proof. intros x y H; exact H. Qed. - - Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. - Proof. - constructor. - - exact (SRadd_ext SReqe). - - exact (SRmul_ext SReqe). - - exact SRopp_ext. - Qed. - - Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. - Proof. reflexivity. Qed. - - Lemma SRopp_add : forall x y, -(x + y) == -x + -y. - Proof. reflexivity. Qed. - - Lemma SRsub_def : forall x y, x - y == x + -y. - Proof. reflexivity. Qed. - - Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. - Proof (mk_art 0 1 radd rmul SRsub SRopp req - (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) - (SRmul_1_l SRth) (SRmul_0_l SRth) - (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) - SRopp_mul_l SRopp_add SRsub_def). - - (** Identity morphism for semi-ring equipped with their almost-ring structure*) - Variable reqb : R->R->bool. - - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - - Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req - 0 1 radd rmul SRsub SRopp reqb (@IDphi R). - Proof. - now apply mkmorph. - Qed. - - (* a semi_morph can be extended to a ring_morph for the almost_ring derived - from a semi_ring, provided the ring is a setoid (we only need - reflexivity) *) - Variable C : Type. - Variable (cO cI : C) (cadd cmul: C->C->C). - Variable (ceqb : C -> C -> bool). - Variable phi : C -> R. - Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. - - Lemma SRmorph_Rmorph : - ring_morph rO rI radd rmul SRsub SRopp req - cO cI cadd cmul cadd (fun x => x) ceqb phi. - Proof. - case Smorph; now constructor. - Qed. - - End SEMI_RING. - Infix "-" := rsub. - Notation "- x" := (ropp x). - - Variable Reqe : ring_eq_ext radd rmul ropp req. - - Add Morphism radd with signature (req ==> req ==> req) as radd_ext2. - Proof. exact (Radd_ext Reqe). Qed. - - Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext2. - Proof. exact (Rmul_ext Reqe). Qed. - - Add Morphism ropp with signature (req ==> req) as ropp_ext2. - Proof. exact (Ropp_ext Reqe). Qed. - - Section RING. - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - - (** Rings are almost rings*) - Lemma Rmul_0_l x : 0 * x == 0. - Proof. - setoid_replace (0*x) with ((0+1)*x + -x). - now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth). - - rewrite (Rdistr_l Rth), (Rmul_1_l Rth). - rewrite <- (Radd_assoc Rth), (Ropp_def Rth). - now rewrite (Radd_comm Rth), (Radd_0_l Rth). - Qed. - - Lemma Ropp_mul_l x y : -(x * y) == -x * y. - Proof. - rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). - rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). - rewrite (Radd_comm Rth (-x)), (Ropp_def Rth). - now rewrite Rmul_0_l, (Radd_0_l Rth). - Qed. - - Lemma Ropp_add x y : -(x + y) == -x + -y. - Proof. - rewrite <- ((Radd_0_l Rth) (-(x+y))). - rewrite <- ((Ropp_def Rth) x). - rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). - rewrite <- ((Ropp_def Rth) y). - rewrite ((Radd_comm Rth) x). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (-y)). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y), (Ropp_def Rth). - rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth). - now apply (Radd_comm Rth). - Qed. - - Lemma Ropp_opp x : - -x == x. - Proof. - rewrite <- (Radd_0_l Rth (- -x)). - rewrite <- (Ropp_def Rth x). - rewrite <- (Radd_assoc Rth), (Ropp_def Rth). - rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth). - Qed. - - Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Proof - (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) - (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) - Ropp_mul_l Ropp_add (Rsub_def Rth)). - - (** Every semi morphism between two rings is a morphism*) - Variable C : Type. - Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). - Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). - Variable phi : C -> R. - Infix "+!" := cadd. Infix "*!" := cmul. - Infix "-!" := csub. Notation "-! x" := (copp x). - Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). - Variable Csth : Equivalence ceq. - Variable Ceqe : ring_eq_ext cadd cmul copp ceq. - - Add Parametric Relation : C ceq - reflexivity proved by (@Equivalence_Reflexive _ _ Csth) - symmetry proved by (@Equivalence_Symmetric _ _ Csth) - transitivity proved by (@Equivalence_Transitive _ _ Csth) - as C_setoid. - - Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. - Proof. exact (Radd_ext Ceqe). Qed. - - Add Morphism cmul with signature (ceq ==> ceq ==> ceq) as cmul_ext. - Proof. exact (Rmul_ext Ceqe). Qed. - - Add Morphism copp with signature (ceq ==> ceq) as copp_ext. - Proof. exact (Ropp_ext Ceqe). Qed. - - Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. - Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. - Variable phi_ext : forall x y, ceq x y -> [x] == [y]. - - Add Morphism phi with signature (ceq ==> req) as phi_ext1. - Proof. exact phi_ext. Qed. - - Lemma Smorph_opp x : [-!x] == -[x]. - Proof. - rewrite <- (Radd_0_l Rth [-!x]). - rewrite <- ((Ropp_def Rth) [x]). - rewrite ((Radd_comm Rth) [x]). - rewrite <- (Radd_assoc Rth). - rewrite <- (Smorph_add Smorph). - rewrite (Ropp_def Cth). - rewrite (Smorph0 Smorph). - rewrite (Radd_comm Rth (-[x])). - now apply (Radd_0_l Rth). - Qed. - - Lemma Smorph_sub x y : [x -! y] == [x] - [y]. - Proof. - rewrite (Rsub_def Cth), (Rsub_def Rth). - now rewrite (Smorph_add Smorph), Smorph_opp. - Qed. - - Lemma Smorph_morph : - ring_morph 0 1 radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - Proof - (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi - (Smorph0 Smorph) (Smorph1 Smorph) - (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp - (Smorph_eq Smorph)). - - End RING. - - (** Useful lemmas on almost ring *) - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - - Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. -Proof. -elim ARth; intros. -constructor; trivial. -Qed. - - Instance ARsub_ext : Proper (req ==> req ==> req) rsub. - Proof. - intros x1 x2 Ex y1 y2 Ey. - now rewrite !(ARsub_def ARth), Ex, Ey. - Qed. - - Ltac mrewrite := - repeat first - [ rewrite (ARadd_0_l ARth) - | rewrite <- ((ARadd_comm ARth) 0) - | rewrite (ARmul_1_l ARth) - | rewrite <- ((ARmul_comm ARth) 1) - | rewrite (ARmul_0_l ARth) - | rewrite <- ((ARmul_comm ARth) 0) - | rewrite (ARdistr_l ARth) - | reflexivity - | match goal with - | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) - end]. - - Lemma ARadd_0_r x : x + 0 == x. - Proof. mrewrite. Qed. - - Lemma ARmul_1_r x : x * 1 == x. - Proof. mrewrite. Qed. - - Lemma ARmul_0_r x : x * 0 == 0. - Proof. mrewrite. Qed. - - Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. - Proof. - mrewrite. now rewrite !(ARmul_comm ARth z). - Qed. - - Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. - Proof. - now rewrite <-(ARadd_assoc ARth x), (ARadd_comm ARth x). - Qed. - - Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. - Proof. - now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x). - Qed. - - Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x. - Proof. - now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x). - Qed. - - Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x. - Proof. - now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x). - Qed. - - Lemma ARopp_mul_r x y : - (x * y) == x * -y. - Proof. - rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth). - now apply (ARmul_comm ARth). - Qed. - - Lemma ARopp_zero : -0 == 0. - Proof. - now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r. - Qed. - -End ALMOST_RING. - -Section AddRing. - -(* Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. *) - -Inductive ring_kind : Type := -| Abstract -| Computational - (R:Type) - (req : R -> R -> Prop) - (reqb : R -> R -> bool) - (_ : forall x y, (reqb x y) = true -> req x y) -| Morphism - (R : Type) - (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) - (req : R -> R -> Prop) - (C : Type) - (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) - (ceqb : C->C->bool) - phi - (_ : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi). - -End AddRing. - - -(** Some simplification tactics*) -Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). - -Ltac gen_srewrite Rsth Reqe ARth := - repeat first - [ gen_reflexivity Rsth - | progress rewrite (ARopp_zero Rsth Reqe ARth) - | rewrite (ARadd_0_l ARth) - | rewrite (ARadd_0_r Rsth ARth) - | rewrite (ARmul_1_l ARth) - | rewrite (ARmul_1_r Rsth ARth) - | rewrite (ARmul_0_l ARth) - | rewrite (ARmul_0_r Rsth ARth) - | rewrite (ARdistr_l ARth) - | rewrite (ARdistr_r Rsth Reqe ARth) - | rewrite (ARadd_assoc ARth) - | rewrite (ARmul_assoc ARth) - | progress rewrite (ARopp_add ARth) - | progress rewrite (ARsub_def ARth) - | progress rewrite <- (ARopp_mul_l ARth) - | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. - -Ltac gen_srewrite_sr Rsth Reqe ARth := - repeat first - [ gen_reflexivity Rsth - | progress rewrite (ARopp_zero Rsth Reqe ARth) - | rewrite (ARadd_0_l ARth) - | rewrite (ARadd_0_r Rsth ARth) - | rewrite (ARmul_1_l ARth) - | rewrite (ARmul_1_r Rsth ARth) - | rewrite (ARmul_0_l ARth) - | rewrite (ARmul_0_r Rsth ARth) - | rewrite (ARdistr_l ARth) - | rewrite (ARdistr_r Rsth Reqe ARth) - | rewrite (ARadd_assoc ARth) - | rewrite (ARmul_assoc ARth) ]. - -Ltac gen_add_push add Rsth Reqe ARth x := - repeat (match goal with - | |- context [add (add ?y x) ?z] => - progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) - | |- context [add (add x ?y) ?z] => - progress rewrite (ARadd_assoc1 Rsth ARth x y z) - | |- context [(add x ?y)] => - progress rewrite (ARadd_comm ARth x y) - end). - -Ltac gen_mul_push mul Rsth Reqe ARth x := - repeat (match goal with - | |- context [mul (mul ?y x) ?z] => - progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) - | |- context [mul (mul x ?y) ?z] => - progress rewrite (ARmul_assoc1 Rsth ARth x y z) - | |- context [(mul x ?y)] => - progress rewrite (ARmul_comm ARth x y) - end). diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v deleted file mode 100644 index b3ed0be916..0000000000 --- a/plugins/setoid_ring/Rings_Q.v +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Cring. -Require Export Integral_domain. - -(* Rational numbers *) -Require Import QArith. - -Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). -Defined. - -Instance Qri : (Ring (Ro:=Qops)). -constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. -apply Qopp_comp. - exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. - exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. -reflexivity. exact Qplus_opp_r. -Defined. - -Instance Qcri: (Cring (Rr:=Qri)). -red. exact Qmult_comm. Defined. - -Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -unfold Qeq. simpl. auto with *. Qed. - -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. -exact Qmult_integral. exact Q_one_zero. Defined. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v deleted file mode 100644 index ec91fa9e97..0000000000 --- a/plugins/setoid_ring/Rings_R.v +++ /dev/null @@ -1,45 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Cring. -Require Export Integral_domain. - -(* Real numbers *) -Require Import Reals. -Require Import RealField. - -Lemma Rsth : Setoid_Theory R (@eq R). -constructor;red;intros;subst;trivial. -Qed. - -Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). -Defined. - -Instance Rri : (Ring (Ro:=Rops)). -constructor; -try (try apply Rsth; - try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; - intros; try rewrite H; try rewrite H0; reflexivity)). - exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. - exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. - exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. -exact Rplus_opp_r. -Defined. - -Instance Rcri: (Cring (Rr:=Rri)). -red. exact Rmult_comm. Defined. - -Lemma R_one_zero: 1%R <> 0%R. -discrR. -Qed. - -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. -exact Rmult_integral. exact R_one_zero. Defined. diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v deleted file mode 100644 index 8a51bcea02..0000000000 --- a/plugins/setoid_ring/Rings_Z.v +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Cring. -Require Export Integral_domain. -Require Export Ncring_initial. -Require Export Omega. - -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -Lemma Z_one_zero: 1%Z <> 0%Z. -Proof. discriminate. Qed. - -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v deleted file mode 100644 index 833e19a698..0000000000 --- a/plugins/setoid_ring/ZArithRing.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Ring. -Require Import ZArith_base. -Require Import Zpow_def. - -Import InitialRing. - -Set Implicit Arguments. - -Ltac Zcst t := - match isZcst t with - true => t - | _ => constr:(NotConstant) - end. - -Ltac isZpow_coef t := - match t with - | Zpos ?p => isPcst p - | Z0 => constr:(true) - | _ => constr:(false) - end. - -Notation N_of_Z := Z.to_N (only parsing). - -Ltac Zpow_tac t := - match isZpow_coef t with - | true => constr:(N_of_Z t) - | _ => constr:(NotConstant) - end. - -Ltac Zpower_neg := - repeat match goal with - | [|- ?G] => - match G with - | context c [Z.pow _ (Zneg _)] => - let t := context c [Z0] in - change t - end - end. - -Add Ring Zr : Zth - (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ], - power_tac Zpower_theory [Zpow_tac], - (* The following two options are not needed; they are the default choice - when the set of coefficient is the usual ring Z *) - div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), - sign get_signZ_th). - - diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v deleted file mode 100644 index 475859fcc2..0000000000 --- a/plugins/ssr/ssrbool.v +++ /dev/null @@ -1,2035 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -Require Bool. -Require Import ssreflect ssrfun. - -(** - A theory of boolean predicates and operators. A large part of this file is - concerned with boolean reflection. - Definitions and notations: - is_true b == the coercion of b : bool to Prop (:= b = true). - This is just input and displayed as `b''. - reflect P b == the reflection inductive predicate, asserting - that the logical proposition P : prop with the - formula b : bool. Lemmas asserting reflect P b - are often referred to as "views". - iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection - views: iffP is used to prove reflection from - logical equivalence, appP to compose views, and - sameP and rwP to perform boolean and setoid - rewriting. - elimT :: coercion reflect >-> Funclass, which allows the - direct application of `reflect' views to - boolean assertions. - decidable P <-> P is effectively decidable (:= {P} + {~ P}. - contra, contraL, ... :: contraposition lemmas. - altP my_viewP :: natural alternative for reflection; given - lemma myviewP: reflect my_Prop my_formula, - have #[#myP | not_myP#]# := altP my_viewP. - generates two subgoals, in which my_formula has - been replaced by true and false, resp., with - new assumptions myP : my_Prop and - not_myP: ~~ my_formula. - Caveat: my_formula must be an APPLICATION, not - a variable, constant, let-in, etc. (due to the - poor behaviour of dependent index matching). - boolP my_formula :: boolean disjunction, equivalent to - altP (idP my_formula) but circumventing the - dependent index capture issue; destructing - boolP my_formula generates two subgoals with - assumptions my_formula and ~~ myformula. As - with altP, my_formula must be an application. - \unless C, P <-> we can assume property P when a something that - holds under condition C (such as C itself). - := forall G : Prop, (C -> G) -> (P -> G) -> G. - This is just C \/ P or rather its impredicative - encoding, whose usage better fits the above - description: given a lemma UCP whose conclusion - is \unless C, P we can assume P by writing: - wlog hP: / P by apply/UCP; (prove C -> goal). - or even apply: UCP id _ => hP if the goal is C. - classically P <-> we can assume P when proving is_true b. - := forall b : bool, (P -> b) -> b. - This is equivalent to ~ (~ P) when P : Prop. - implies P Q == wrapper variant type that coerces to P -> Q and - can be used as a P -> Q view unambiguously. - Useful to avoid spurious insertion of <-> views - when Q is a conjunction of foralls, as in Lemma - all_and2 below; conversely, avoids confusion in - apply views for impredicative properties, such - as \unless C, P. Also supports contrapositives. - a && b == the boolean conjunction of a and b. - a || b == the boolean disjunction of a and b. - a ==> b == the boolean implication of b by a. - ~~ a == the boolean negation of a. - a (+) b == the boolean exclusive or (or sum) of a and b. - #[# /\ P1 , P2 & P3 #]# == multiway logical conjunction, up to 5 terms. - #[# \/ P1 , P2 | P3 #]# == multiway logical disjunction, up to 4 terms. - #[#&& a, b, c & d#]# == iterated, right associative boolean conjunction - with arbitrary arity. - #[#|| a, b, c | d#]# == iterated, right associative boolean disjunction - with arbitrary arity. - #[#==> a, b, c => d#]# == iterated, right associative boolean implication - with arbitrary arity. - and3P, ... == specific reflection lemmas for iterated - connectives. - andTb, orbAC, ... == systematic names for boolean connective - properties (see suffix conventions below). - prop_congr == a tactic to move a boolean equality from - its coerced form in Prop to the equality - in bool. - bool_congr == resolution tactic for blindly weeding out - like terms from boolean equalities (can fail). - This file provides a theory of boolean predicates and relations: - pred T == the type of bool predicates (:= T -> bool). - simpl_pred T == the type of simplifying bool predicates, based on - the simpl_fun type from ssrfun.v. - mem_pred T == a specialized form of simpl_pred for "collective" - predicates (see below). - rel T == the type of bool relations. - := T -> pred T or T -> T -> bool. - simpl_rel T == type of simplifying relations. - := T -> simpl_pred T - predType == the generic predicate interface, supported for - for lists and sets. - pred_sort == the predType >-> Type projection; pred_sort is - itself a Coercion target class. Declaring a - coercion to pred_sort is an alternative way of - equiping a type with a predType structure, which - interoperates better with coercion subtyping. - This is used, e.g., for finite sets, so that finite - groups inherit the membership operation by - coercing to sets. - {pred T} == a type convertible to pred T, but whose head - constant is pred_sort. This type should be used - for parameters that can be used as collective - predicates (see below), as this will allow passing - in directly collections that implement predType - by coercion as described above, e.g., finite sets. - := pred_sort (predPredType T) - If P is a predicate the proposition "x satisfies P" can be written - applicatively as (P x), or using an explicit connective as (x \in P); in - the latter case we say that P is a "collective" predicate. We use A, B - rather than P, Q for collective predicates: - x \in A == x satisfies the (collective) predicate A. - x \notin A == x doesn't satisfy the (collective) predicate A. - The pred T type can be used as a generic predicate type for either kind, - but the two kinds of predicates should not be confused. When a "generic" - pred T value of one type needs to be passed as the other the following - conversions should be used explicitly: - SimplPred P == a (simplifying) applicative equivalent of P. - mem A == an applicative equivalent of collective predicate A: - mem A x simplifies to x \in A, as mem A has in - fact type mem_pred T. - --> In user notation collective predicates _only_ occur as arguments to mem: - A only appears as (mem A). This is hidden by notation, e.g., - x \in A := in_mem x (mem A) here, enum A := enum_mem (mem A) in fintype. - This makes it possible to unify the various ways in which A can be - interpreted as a predicate, for both pattern matching and display. - Alternatively one can use the syntax for explicit simplifying predicates - and relations (in the following x is bound in E): - #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. - #[#pred x : T | E#]# == predicate x => E, with a cast on the argument. - #[#pred : T | P#]# == constant predicate P on type T. - #[#pred x | E1 & E2#]# == #[#pred x | E1 && E2#]#; an x : T cast is allowed. - #[#pred x in A#]# == #[#pred x | x in A#]#. - #[#pred x in A | E#]# == #[#pred x | x in A & E#]#. - #[#pred x in A | E1 & E2#]# == #[#pred x in A | E1 && E2#]#. - #[#predU A & B#]# == union of two collective predicates A and B. - #[#predI A & B#]# == intersection of collective predicates A and B. - #[#predD A & B#]# == difference of collective predicates A and B. - #[#predC A#]# == complement of the collective predicate A. - #[#preim f of A#]# == preimage under f of the collective predicate A. - predU P Q, ..., preim f P == union, etc of applicative predicates. - pred0 == the empty predicate. - predT == the total (always true) predicate. - if T : predArgType, then T coerces to predT. - {: T} == T cast to predArgType (e.g., {: bool * nat}). - In the following, x and y are bound in E: - #[#rel x y | E#]# == simplifying relation x, y => E. - #[#rel x y : T | E#]# == simplifying relation with arguments cast. - #[#rel x y in A & B | E#]# == #[#rel x y | #[#&& x \in A, y \in B & E#]# #]#. - #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. - #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. - #[#rel x y in A#]# == #[#rel x y in A & A#]#. - relU R S == union of relations R and S. - relpre f R == preimage of relation R under f. - xpredU, ..., xrelpre == lambda terms implementing predU, ..., etc. - Explicit values of type pred T (i.e., lamdba terms) should always be used - applicatively, while values of collection types implementing the predType - interface, such as sequences or sets should always be used as collective - predicates. Defined constants and functions of type pred T or simpl_pred T - as well as the explicit simpl_pred T values described below, can generally - be used either way. Note however that x \in A will not auto-simplify when - A is an explicit simpl_pred T value; the generic simplification rule inE - must be used (when A : pred T, the unfold_in rule can be used). Constants - of type pred T with an explicit simpl_pred value do not auto-simplify when - used applicatively, but can still be expanded with inE. This behavior can - be controlled as follows: - Let A : collective_pred T := #[#pred x | ... #]#. - The collective_pred T type is just an alias for pred T, but this cast - stops rewrite inE from expanding the definition of A, thus treating A - into an abstract collection (unfold_in or in_collective can be used to - expand manually). - Let A : applicative_pred T := #[#pred x | ... #]#. - This cast causes inE to turn x \in A into the applicative A x form; - A will then have to unfolded explicitly with the /A rule. This will - also apply to any definition that reduces to A (e.g., Let B := A). - Canonical A_app_pred := ApplicativePred A. - This declaration, given after definition of A, similarly causes inE to - turn x \in A into A x, but in addition allows the app_predE rule to - turn A x back into x \in A; it can be used for any definition of type - pred T, which makes it especially useful for ambivalent predicates - as the relational transitive closure connect, that are used in both - applicative and collective styles. - Purely for aesthetics, we provide a subtype of collective predicates: - qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T - coerces to pred_sort and thus behaves as a collective - predicate, but x \in A and x \notin A are displayed as: - x \is A and x \isn't A when q = 0, - x \is a A and x \isn't a A when q = 1, - x \is an A and x \isn't an A when q = 2, respectively. - #[#qualify x | P#]# := Qualifier 0 (fun x => P), constructor for the above. - #[#qualify x : T | P#]#, #[#qualify a x | P#]#, #[#qualify an X | P#]#, etc. - variants of the above with type constraints and different - values of q. - We provide an internal interface to support attaching properties (such as - being multiplicative) to predicates: - pred_key p == phantom type that will serve as a support for properties - to be attached to p : {pred _}; instances should be - created with Fact/Qed so as to be opaque. - KeyedPred k_p == an instance of the interface structure that attaches - (k_p : pred_key P) to P; the structure projection is a - coercion to pred_sort. - KeyedQualifier k_q == an instance of the interface structure that attaches - (k_q : pred_key q) to (q : qualifier n T). - DefaultPredKey p == a default value for pred_key p; the vernacular command - Import DefaultKeying attaches this key to all predicates - that are not explicitly keyed. - Keys can be used to attach properties to predicates, qualifiers and - generic nouns in a way that allows them to be used transparently. The key - projection of a predicate property structure such as unsignedPred should - be a pred_key, not a pred, and corresponding lemmas will have the form - Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : - {mono -%%R: x / x \in kS}. - Because x \in kS will be displayed as x \in S (or x \is S, etc), the - canonical instance of opprPred will not normally be exposed (it will also - be erased by /= simplification). In addition each predicate structure - should have a DefaultPredKey Canonical instance that simply issues the - property as a proof obligation (which can be caught by the Prop-irrelevant - feature of the ssreflect plugin). - Some properties of predicates and relations: - A =i B <-> A and B are extensionally equivalent. - {subset A <= B} <-> A is a (collective) subpredicate of B. - subpred P Q <-> P is an (applicative) subpredicate or Q. - subrel R S <-> R is a subrelation of S. - In the following R is in rel T: - reflexive R <-> R is reflexive. - irreflexive R <-> R is irreflexive. - symmetric R <-> R (in rel T) is symmetric (equation). - pre_symmetric R <-> R is symmetric (implication). - antisymmetric R <-> R is antisymmetric. - total R <-> R is total. - transitive R <-> R is transitive. - left_transitive R <-> R is a congruence on its left hand side. - right_transitive R <-> R is a congruence on its right hand side. - equivalence_rel R <-> R is an equivalence relation. - Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, - P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : - {for y, P1} <-> Qx{y / x}. - {in A, P1} <-> forall x, x \in A -> Qx. - {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. - {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. - {in A1 & A2 & A3, Q3} <-> forall x y z, - x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. - {in A1 & A2 &, Q3} := {in A1 & A2 & A2, Q3}. - {in A1 && A3, Q3} := {in A1 & A1 & A3, Q3}. - {in A &&, Q3} := {in A & A & A, Q3}. - {in A, bijective f} <-> f has a right inverse in A. - {on C, P1} <-> forall x, (f x) \in C -> Qx - when P1 is also convertible to Pf f, e.g., - {on C, involutive f}. - {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy - when P2 is also convertible to Pf f, e.g., - {on C &, injective f}. - {on C, P1' & g} == forall x, (f x) \in cd -> Qx - when P1' is convertible to Pf f - and P1' g is convertible to forall x, Qx, e.g., - {on C, cancel f & g}. - {on C, bijective f} == f has a right inverse on C. - This file extends the lemma name suffix conventions of ssrfun as follows: - A -- associativity, as in andbA : associative andb. - AC -- right commutativity. - ACA -- self-interchange (inner commutativity), e.g., - orbACA : (a || b) || (c || d) = (a || c) || (b || d). - b -- a boolean argument, as in andbb : idempotent andb. - C -- commutativity, as in andbC : commutative andb, - or predicate complement, as in predC. - CA -- left commutativity. - D -- predicate difference, as in predD. - E -- elimination, as in negbFE : ~~ b = false -> b. - F or f -- boolean false, as in andbF : b && false = false. - I -- left/right injectivity, as in addbI : right_injective addb, - or predicate intersection, as in predI. - l -- a left-hand operation, as andb_orl : left_distributive andb orb. - N or n -- boolean negation, as in andbN : a && (~~ a) = false. - P -- a characteristic property, often a reflection lemma, as in - andP : reflect (a /\ b) (a && b). - r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. - T or t -- boolean truth, as in andbT: right_id true andb. - U -- predicate union, as in predU. - W -- weakening, as in in1W : (forall x, P) -> {in D, forall x, P}. **) - - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. -Set Warnings "-projection-no-head-constant". - -Notation reflect := Bool.reflect. -Notation ReflectT := Bool.ReflectT. -Notation ReflectF := Bool.ReflectF. - -Reserved Notation "~~ b" (at level 35, right associativity). -Reserved Notation "b ==> c" (at level 55, right associativity). -Reserved Notation "b1 (+) b2" (at level 50, left associativity). - -Reserved Notation "x \in A" (at level 70, no associativity, - format "'[hv' x '/ ' \in A ']'"). -Reserved Notation "x \notin A" (at level 70, no associativity, - format "'[hv' x '/ ' \notin A ']'"). -Reserved Notation "x \is A" (at level 70, no associativity, - format "'[hv' x '/ ' \is A ']'"). -Reserved Notation "x \isn't A" (at level 70, no associativity, - format "'[hv' x '/ ' \isn't A ']'"). -Reserved Notation "x \is 'a' A" (at level 70, no associativity, - format "'[hv' x '/ ' \is 'a' A ']'"). -Reserved Notation "x \isn't 'a' A" (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'a' A ']'"). -Reserved Notation "x \is 'an' A" (at level 70, no associativity, - format "'[hv' x '/ ' \is 'an' A ']'"). -Reserved Notation "x \isn't 'an' A" (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'an' A ']'"). -Reserved Notation "p1 =i p2" (at level 70, no associativity, - format "'[hv' p1 '/ ' =i p2 ']'"). -Reserved Notation "{ 'subset' A <= B }" (at level 0, A, B at level 69, - format "'[hv' { 'subset' A '/ ' <= B } ']'"). - -Reserved Notation "{ : T }" (at level 0, format "{ : T }"). -Reserved Notation "{ 'pred' T }" (at level 0, format "{ 'pred' T }"). -Reserved Notation "[ 'predType' 'of' T ]" (at level 0, - format "[ 'predType' 'of' T ]"). - -Reserved Notation "[ 'pred' : T | E ]" (at level 0, - format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, - format "'[hv' [ 'pred' x | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, - format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, - format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). -Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, - format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). -Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, - format "'[hv' [ 'pred' x 'in' A ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, - format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, - format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). - -Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' x | '/ ' P ] ']'"). -Reserved Notation "[ 'qualify' x : T | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' x : T | '/ ' P ] ']'"). -Reserved Notation "[ 'qualify' 'a' x | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'"). -Reserved Notation "[ 'qualify' 'a' x : T | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'a' x : T | '/ ' P ] ']'"). -Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'"). -Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). - -Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, - format "'[hv' [ 'rel' x y 'in' A ] ']'"). - -Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). -Reserved Notation "[ 'predI' A & B ]" (at level 0, - format "[ 'predI' A & B ]"). -Reserved Notation "[ 'predU' A & B ]" (at level 0, - format "[ 'predU' A & B ]"). -Reserved Notation "[ 'predD' A & B ]" (at level 0, - format "[ 'predD' A & B ]"). -Reserved Notation "[ 'predC' A ]" (at level 0, - format "[ 'predC' A ]"). -Reserved Notation "[ 'preim' f 'of' A ]" (at level 0, - format "[ 'preim' f 'of' A ]"). - -Reserved Notation "\unless C , P" (at level 200, C at level 100, - format "'[hv' \unless C , '/ ' P ']'"). - -Reserved Notation "{ 'for' x , P }" (at level 0, - format "'[hv' { 'for' x , '/ ' P } ']'"). -Reserved Notation "{ 'in' d , P }" (at level 0, - format "'[hv' { 'in' d , '/ ' P } ']'"). -Reserved Notation "{ 'in' d1 & d2 , P }" (at level 0, - format "'[hv' { 'in' d1 & d2 , '/ ' P } ']'"). -Reserved Notation "{ 'in' d & , P }" (at level 0, - format "'[hv' { 'in' d & , '/ ' P } ']'"). -Reserved Notation "{ 'in' d1 & d2 & d3 , P }" (at level 0, - format "'[hv' { 'in' d1 & d2 & d3 , '/ ' P } ']'"). -Reserved Notation "{ 'in' d1 & & d3 , P }" (at level 0, - format "'[hv' { 'in' d1 & & d3 , '/ ' P } ']'"). -Reserved Notation "{ 'in' d1 & d2 & , P }" (at level 0, - format "'[hv' { 'in' d1 & d2 & , '/ ' P } ']'"). -Reserved Notation "{ 'in' d & & , P }" (at level 0, - format "'[hv' { 'in' d & & , '/ ' P } ']'"). -Reserved Notation "{ 'on' cd , P }" (at level 0, - format "'[hv' { 'on' cd , '/ ' P } ']'"). -Reserved Notation "{ 'on' cd & , P }" (at level 0, - format "'[hv' { 'on' cd & , '/ ' P } ']'"). -Reserved Notation "{ 'on' cd , P & g }" (at level 0, g at level 8, - format "'[hv' { 'on' cd , '/ ' P & g } ']'"). -Reserved Notation "{ 'in' d , 'bijective' f }" (at level 0, f at level 8, - format "'[hv' { 'in' d , '/ ' 'bijective' f } ']'"). -Reserved Notation "{ 'on' cd , 'bijective' f }" (at level 0, f at level 8, - format "'[hv' { 'on' cd , '/ ' 'bijective' f } ']'"). - - -(** - We introduce a number of n-ary "list-style" notations that share a common - format, namely - #[#op arg1, arg2, ... last_separator last_arg#]# - This usually denotes a right-associative applications of op, e.g., - #[#&& a, b, c & d#]# denotes a && (b && (c && d)) - The last_separator must be a non-operator token. Here we use &, | or =>; - our default is &, but we try to match the intended meaning of op. The - separator is a workaround for limitations of the parsing engine; the same - limitations mean the separator cannot be omitted even when last_arg can. - The Notation declarations are complicated by the separate treatment for - some fixed arities (binary for bool operators, and all arities for Prop - operators). - We also use the square brackets in comprehension-style notations - #[#type var separator expr#]# - where "type" is the type of the comprehension (e.g., pred) and "separator" - is | or => . It is important that in other notations a leading square - bracket #[# is always followed by an operator symbol or a fixed identifier. **) - -Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). -Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format - "'[hv' [ /\ '[' P1 , '/' P2 ']' '/ ' & P3 ] ']'"). -Reserved Notation "[ /\ P1 , P2 , P3 & P4 ]" (at level 0, format - "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 ']' '/ ' & P4 ] ']'"). -Reserved Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" (at level 0, format - "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 ']' '/ ' & P5 ] ']'"). - -Reserved Notation "[ \/ P1 | P2 ]" (at level 0, only parsing). -Reserved Notation "[ \/ P1 , P2 | P3 ]" (at level 0, format - "'[hv' [ \/ '[' P1 , '/' P2 ']' '/ ' | P3 ] ']'"). -Reserved Notation "[ \/ P1 , P2 , P3 | P4 ]" (at level 0, format - "'[hv' [ \/ '[' P1 , '/' P2 , '/' P3 ']' '/ ' | P4 ] ']'"). - -Reserved Notation "[ && b1 & c ]" (at level 0, only parsing). -Reserved Notation "[ && b1 , b2 , .. , bn & c ]" (at level 0, format - "'[hv' [ && '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' & c ] ']'"). - -Reserved Notation "[ || b1 | c ]" (at level 0, only parsing). -Reserved Notation "[ || b1 , b2 , .. , bn | c ]" (at level 0, format - "'[hv' [ || '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' | c ] ']'"). - -Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). -Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format - "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). - -(** Shorter delimiter **) -Delimit Scope bool_scope with B. -Open Scope bool_scope. - -(** An alternative to xorb that behaves somewhat better wrt simplification. **) -Definition addb b := if b then negb else id. - -(** Notation for && and || is declared in Init.Datatypes. **) -Notation "~~ b" := (negb b) : bool_scope. -Notation "b ==> c" := (implb b c) : bool_scope. -Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. - -(** Constant is_true b := b = true is defined in Init.Datatypes. **) -Coercion is_true : bool >-> Sortclass. (* Prop *) - -Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. -Proof. by move=> b b' ->. Qed. - -Ltac prop_congr := apply: prop_congr. - -(** Lemmas for trivial. **) -Lemma is_true_true : true. Proof. by []. Qed. -Lemma not_false_is_true : ~ false. Proof. by []. Qed. -Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. -Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. - -(** Shorter names. **) -Definition isT := is_true_true. -Definition notF := not_false_is_true. - -(** Negation lemmas. **) - -(** - We generally take NEGATION as the standard form of a false condition: - negative boolean hypotheses should be of the form ~~ b, rather than ~ b or - b = false, as much as possible. **) - -Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. -Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. -Lemma negbF b : (b : bool) -> ~~ b = false. Proof. by case: b. Qed. -Lemma negbFE b : ~~ b = false -> b. Proof. by case: b. Qed. -Lemma negbK : involutive negb. Proof. by case. Qed. -Lemma negbNE b : ~~ ~~ b -> b. Proof. by case: b. Qed. - -Lemma negb_inj : injective negb. Proof. exact: can_inj negbK. Qed. -Lemma negbLR b c : b = ~~ c -> ~~ b = c. Proof. exact: canLR negbK. Qed. -Lemma negbRL b c : ~~ b = c -> b = ~~ c. Proof. exact: canRL negbK. Qed. - -Lemma contra (c b : bool) : (c -> b) -> ~~ b -> ~~ c. -Proof. by case: b => //; case: c. Qed. -Definition contraNN := contra. - -Lemma contraL (c b : bool) : (c -> ~~ b) -> b -> ~~ c. -Proof. by case: b => //; case: c. Qed. -Definition contraTN := contraL. - -Lemma contraR (c b : bool) : (~~ c -> b) -> ~~ b -> c. -Proof. by case: b => //; case: c. Qed. -Definition contraNT := contraR. - -Lemma contraLR (c b : bool) : (~~ c -> ~~ b) -> b -> c. -Proof. by case: b => //; case: c. Qed. -Definition contraTT := contraLR. - -Lemma contraT b : (~~ b -> false) -> b. Proof. by case: b => // ->. Qed. - -Lemma wlog_neg b : (~~ b -> b) -> b. Proof. by case: b => // ->. Qed. - -Lemma contraFT (c b : bool) : (~~ c -> b) -> b = false -> c. -Proof. by move/contraR=> notb_c /negbT. Qed. - -Lemma contraFN (c b : bool) : (c -> b) -> b = false -> ~~ c. -Proof. by move/contra=> notb_notc /negbT. Qed. - -Lemma contraTF (c b : bool) : (c -> ~~ b) -> b -> c = false. -Proof. by move/contraL=> b_notc /b_notc/negbTE. Qed. - -Lemma contraNF (c b : bool) : (c -> b) -> ~~ b -> c = false. -Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. - -Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. -Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. - -(** - Coercion of sum-style datatypes into bool, which makes it possible - to use ssr's boolean if rather than Coq's "generic" if. **) - -Coercion isSome T (u : option T) := if u is Some _ then true else false. - -Coercion is_inl A B (u : A + B) := if u is inl _ then true else false. - -Coercion is_left A B (u : {A} + {B}) := if u is left _ then true else false. - -Coercion is_inleft A B (u : A + {B}) := if u is inleft _ then true else false. - -Prenex Implicits isSome is_inl is_left is_inleft. - -Definition decidable P := {P} + {~ P}. - -(** - Lemmas for ifs with large conditions, which allow reasoning about the - condition without repeating it inside the proof (the latter IS - preferable when the condition is short). - Usage : - if the goal contains (if cond then ...) = ... - case: ifP => Hcond. - generates two subgoal, with the assumption Hcond : cond = true/false - Rewrite if_same eliminates redundant ifs - Rewrite (fun_if f) moves a function f inside an if - Rewrite if_arg moves an argument inside a function-valued if **) - -Section BoolIf. - -Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). - -Variant if_spec (not_b : Prop) : bool -> A -> Set := - | IfSpecTrue of b : if_spec not_b true vT - | IfSpecFalse of not_b : if_spec not_b false vF. - -Lemma ifP : if_spec (b = false) b (if b then vT else vF). -Proof. by case def_b: b; constructor. Qed. - -Lemma ifPn : if_spec (~~ b) b (if b then vT else vF). -Proof. by case def_b: b; constructor; rewrite ?def_b. Qed. - -Lemma ifT : b -> (if b then vT else vF) = vT. Proof. by move->. Qed. -Lemma ifF : b = false -> (if b then vT else vF) = vF. Proof. by move->. Qed. -Lemma ifN : ~~ b -> (if b then vT else vF) = vF. Proof. by move/negbTE->. Qed. - -Lemma if_same : (if b then vT else vT) = vT. -Proof. by case b. Qed. - -Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT. -Proof. by case b. Qed. - -Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF. -Proof. by case b. Qed. - -Lemma if_arg (fT fF : A -> B) : - (if b then fT else fF) x = if b then fT x else fF x. -Proof. by case b. Qed. - -(** Turning a boolean "if" form into an application. **) -Definition if_expr := if b then vT else vF. -Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. - -End BoolIf. - -(** Core (internal) reflection lemmas, used for the three kinds of views. **) - -Section ReflectCore. - -Variables (P Q : Prop) (b c : bool). - -Hypothesis Hb : reflect P b. - -Lemma introNTF : (if c then ~ P else P) -> ~~ b = c. -Proof. by case c; case Hb. Qed. - -Lemma introTF : (if c then P else ~ P) -> b = c. -Proof. by case c; case Hb. Qed. - -Lemma elimNTF : ~~ b = c -> if c then ~ P else P. -Proof. by move <-; case Hb. Qed. - -Lemma elimTF : b = c -> if c then P else ~ P. -Proof. by move <-; case Hb. Qed. - -Lemma equivPif : (Q -> P) -> (P -> Q) -> if b then Q else ~ Q. -Proof. by case Hb; auto. Qed. - -Lemma xorPif : Q \/ P -> ~ (Q /\ P) -> if b then ~ Q else Q. -Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. - -End ReflectCore. - -(** Internal negated reflection lemmas **) -Section ReflectNegCore. - -Variables (P Q : Prop) (b c : bool). -Hypothesis Hb : reflect P (~~ b). - -Lemma introTFn : (if c then ~ P else P) -> b = c. -Proof. by move/(introNTF Hb) <-; case b. Qed. - -Lemma elimTFn : b = c -> if c then ~ P else P. -Proof. by move <-; apply: (elimNTF Hb); case b. Qed. - -Lemma equivPifn : (Q -> P) -> (P -> Q) -> if b then ~ Q else Q. -Proof. by rewrite -if_neg; apply: equivPif. Qed. - -Lemma xorPifn : Q \/ P -> ~ (Q /\ P) -> if b then Q else ~ Q. -Proof. by rewrite -if_neg; apply: xorPif. Qed. - -End ReflectNegCore. - -(** User-oriented reflection lemmas **) -Section Reflect. - -Variables (P Q : Prop) (b b' c : bool). -Hypotheses (Pb : reflect P b) (Pb' : reflect P (~~ b')). - -Lemma introT : P -> b. Proof. exact: introTF true _. Qed. -Lemma introF : ~ P -> b = false. Proof. exact: introTF false _. Qed. -Lemma introN : ~ P -> ~~ b. Proof. exact: introNTF true _. Qed. -Lemma introNf : P -> ~~ b = false. Proof. exact: introNTF false _. Qed. -Lemma introTn : ~ P -> b'. Proof. exact: introTFn true _. Qed. -Lemma introFn : P -> b' = false. Proof. exact: introTFn false _. Qed. - -Lemma elimT : b -> P. Proof. exact: elimTF true _. Qed. -Lemma elimF : b = false -> ~ P. Proof. exact: elimTF false _. Qed. -Lemma elimN : ~~ b -> ~P. Proof. exact: elimNTF true _. Qed. -Lemma elimNf : ~~ b = false -> P. Proof. exact: elimNTF false _. Qed. -Lemma elimTn : b' -> ~ P. Proof. exact: elimTFn true _. Qed. -Lemma elimFn : b' = false -> P. Proof. exact: elimTFn false _. Qed. - -Lemma introP : (b -> Q) -> (~~ b -> ~ Q) -> reflect Q b. -Proof. by case b; constructor; auto. Qed. - -Lemma iffP : (P -> Q) -> (Q -> P) -> reflect Q b. -Proof. by case: Pb; constructor; auto. Qed. - -Lemma equivP : (P <-> Q) -> reflect Q b. -Proof. by case; apply: iffP. Qed. - -Lemma sumboolP (decQ : decidable Q) : reflect Q decQ. -Proof. by case: decQ; constructor. Qed. - -Lemma appP : reflect Q b -> P -> Q. -Proof. by move=> Qb; move/introT; case: Qb. Qed. - -Lemma sameP : reflect P c -> b = c. -Proof. by case; [apply: introT | apply: introF]. Qed. - -Lemma decPcases : if b then P else ~ P. Proof. by case Pb. Qed. - -Definition decP : decidable P. by case: b decPcases; [left | right]. Defined. - -Lemma rwP : P <-> b. Proof. by split; [apply: introT | apply: elimT]. Qed. - -Lemma rwP2 : reflect Q b -> (P <-> Q). -Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. - -(** Predicate family to reflect excluded middle in bool. **) -Variant alt_spec : bool -> Type := - | AltTrue of P : alt_spec true - | AltFalse of ~~ b : alt_spec false. - -Lemma altP : alt_spec b. -Proof. by case def_b: b / Pb; constructor; rewrite ?def_b. Qed. - -End Reflect. - -Hint View for move/ elimTF|3 elimNTF|3 elimTFn|3 introT|2 introTn|2 introN|2. - -Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. - -Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. - -(** Allow the direct application of a reflection lemma to a boolean assertion. **) -Coercion elimT : reflect >-> Funclass. - -#[universes(template)] -Variant implies P Q := Implies of P -> Q. -Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. -Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. -Proof. by case=> iP ? /iP. Qed. -Coercion impliesP : implies >-> Funclass. -Hint View for move/ impliesPn|2 impliesP|2. -Hint View for apply/ impliesPn|2 impliesP|2. - -(** Impredicative or, which can emulate a classical not-implies. **) -Definition unless condition property : Prop := - forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. - -Notation "\unless C , P" := (unless C P) : type_scope. - -Lemma unlessL C P : implies C (\unless C, P). -Proof. by split=> hC G /(_ hC). Qed. - -Lemma unlessR C P : implies P (\unless C, P). -Proof. by split=> hP G _ /(_ hP). Qed. - -Lemma unless_sym C P : implies (\unless C, P) (\unless P, C). -Proof. by split; apply; [apply/unlessR | apply/unlessL]. Qed. - -Lemma unlessP (C P : Prop) : (\unless C, P) <-> C \/ P. -Proof. by split=> [|[/unlessL | /unlessR]]; apply; [left | right]. Qed. - -Lemma bind_unless C P {Q} : implies (\unless C, P) (\unless (\unless C, Q), P). -Proof. by split; apply=> [hC|hP]; [apply/unlessL/unlessL | apply/unlessR]. Qed. - -Lemma unless_contra b C : implies (~~ b -> C) (\unless C, b). -Proof. by split; case: b => [_ | hC]; [apply/unlessR | apply/unlessL/hC]. Qed. - -(** - Classical reasoning becomes directly accessible for any bool subgoal. - Note that we cannot use "unless" here for lack of universe polymorphism. **) -Definition classically P : Prop := forall b : bool, (P -> b) -> b. - -Lemma classicP (P : Prop) : classically P <-> ~ ~ P. -Proof. -split=> [cP nP | nnP [] // nP]; last by case nnP; move/nP. -by have: P -> false; [move/nP | move/cP]. -Qed. - -Lemma classicW P : P -> classically P. Proof. by move=> hP _ ->. Qed. - -Lemma classic_bind P Q : (P -> classically Q) -> classically P -> classically Q. -Proof. by move=> iPQ cP b /iPQ-/cP. Qed. - -Lemma classic_EM P : classically (decidable P). -Proof. -by case=> // undecP; apply/undecP; right=> notP; apply/notF/undecP; left. -Qed. - -Lemma classic_pick T P : classically ({x : T | P x} + (forall x, ~ P x)). -Proof. -case=> // undecP; apply/undecP; right=> x Px. -by apply/notF/undecP; left; exists x. -Qed. - -Lemma classic_imply P Q : (P -> classically Q) -> classically (P -> Q). -Proof. -move=> iPQ []// notPQ; apply/notPQ=> /iPQ-cQ. -by case: notF; apply: cQ => hQ; apply: notPQ. -Qed. - -(** - List notations for wider connectives; the Prop connectives have a fixed - width so as to avoid iterated destruction (we go up to width 5 for /\, and - width 4 for or). The bool connectives have arbitrary widths, but denote - expressions that associate to the RIGHT. This is consistent with the right - associativity of list expressions and thus more convenient in most proofs. **) - -Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. - -Inductive and4 (P1 P2 P3 P4 : Prop) : Prop := And4 of P1 & P2 & P3 & P4. - -Inductive and5 (P1 P2 P3 P4 P5 : Prop) : Prop := - And5 of P1 & P2 & P3 & P4 & P5. - -Inductive or3 (P1 P2 P3 : Prop) : Prop := Or31 of P1 | Or32 of P2 | Or33 of P3. - -Inductive or4 (P1 P2 P3 P4 : Prop) : Prop := - Or41 of P1 | Or42 of P2 | Or43 of P3 | Or44 of P4. - -Notation "[ /\ P1 & P2 ]" := (and P1 P2) (only parsing) : type_scope. -Notation "[ /\ P1 , P2 & P3 ]" := (and3 P1 P2 P3) : type_scope. -Notation "[ /\ P1 , P2 , P3 & P4 ]" := (and4 P1 P2 P3 P4) : type_scope. -Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" := (and5 P1 P2 P3 P4 P5) : type_scope. - -Notation "[ \/ P1 | P2 ]" := (or P1 P2) (only parsing) : type_scope. -Notation "[ \/ P1 , P2 | P3 ]" := (or3 P1 P2 P3) : type_scope. -Notation "[ \/ P1 , P2 , P3 | P4 ]" := (or4 P1 P2 P3 P4) : type_scope. - -Notation "[ && b1 & c ]" := (b1 && c) (only parsing) : bool_scope. -Notation "[ && b1 , b2 , .. , bn & c ]" := (b1 && (b2 && .. (bn && c) .. )) - : bool_scope. - -Notation "[ || b1 | c ]" := (b1 || c) (only parsing) : bool_scope. -Notation "[ || b1 , b2 , .. , bn | c ]" := (b1 || (b2 || .. (bn || c) .. )) - : bool_scope. - -Notation "[ ==> b1 , b2 , .. , bn => c ]" := - (b1 ==> (b2 ==> .. (bn ==> c) .. )) : bool_scope. -Notation "[ ==> b1 => c ]" := (b1 ==> c) (only parsing) : bool_scope. - -Section AllAnd. - -Variables (T : Type) (P1 P2 P3 P4 P5 : T -> Prop). -Local Notation a P := (forall x, P x). - -Lemma all_and2 : implies (forall x, [/\ P1 x & P2 x]) [/\ a P1 & a P2]. -Proof. by split=> haveP; split=> x; case: (haveP x). Qed. - -Lemma all_and3 : implies (forall x, [/\ P1 x, P2 x & P3 x]) - [/\ a P1, a P2 & a P3]. -Proof. by split=> haveP; split=> x; case: (haveP x). Qed. - -Lemma all_and4 : implies (forall x, [/\ P1 x, P2 x, P3 x & P4 x]) - [/\ a P1, a P2, a P3 & a P4]. -Proof. by split=> haveP; split=> x; case: (haveP x). Qed. - -Lemma all_and5 : implies (forall x, [/\ P1 x, P2 x, P3 x, P4 x & P5 x]) - [/\ a P1, a P2, a P3, a P4 & a P5]. -Proof. by split=> haveP; split=> x; case: (haveP x). Qed. - -End AllAnd. - -Arguments all_and2 {T P1 P2}. -Arguments all_and3 {T P1 P2 P3}. -Arguments all_and4 {T P1 P2 P3 P4}. -Arguments all_and5 {T P1 P2 P3 P4 P5}. - -Lemma pair_andP P Q : P /\ Q <-> P * Q. Proof. by split; case. Qed. - -Section ReflectConnectives. - -Variable b1 b2 b3 b4 b5 : bool. - -Lemma idP : reflect b1 b1. -Proof. by case b1; constructor. Qed. - -Lemma boolP : alt_spec b1 b1 b1. -Proof. exact: (altP idP). Qed. - -Lemma idPn : reflect (~~ b1) (~~ b1). -Proof. by case b1; constructor. Qed. - -Lemma negP : reflect (~ b1) (~~ b1). -Proof. by case b1; constructor; auto. Qed. - -Lemma negPn : reflect b1 (~~ ~~ b1). -Proof. by case b1; constructor. Qed. - -Lemma negPf : reflect (b1 = false) (~~ b1). -Proof. by case b1; constructor. Qed. - -Lemma andP : reflect (b1 /\ b2) (b1 && b2). -Proof. by case b1; case b2; constructor=> //; case. Qed. - -Lemma and3P : reflect [/\ b1, b2 & b3] [&& b1, b2 & b3]. -Proof. by case b1; case b2; case b3; constructor; try by case. Qed. - -Lemma and4P : reflect [/\ b1, b2, b3 & b4] [&& b1, b2, b3 & b4]. -Proof. by case b1; case b2; case b3; case b4; constructor; try by case. Qed. - -Lemma and5P : reflect [/\ b1, b2, b3, b4 & b5] [&& b1, b2, b3, b4 & b5]. -Proof. -by case b1; case b2; case b3; case b4; case b5; constructor; try by case. -Qed. - -Lemma orP : reflect (b1 \/ b2) (b1 || b2). -Proof. by case b1; case b2; constructor; auto; case. Qed. - -Lemma or3P : reflect [\/ b1, b2 | b3] [|| b1, b2 | b3]. -Proof. -case b1; first by constructor; constructor 1. -case b2; first by constructor; constructor 2. -case b3; first by constructor; constructor 3. -by constructor; case. -Qed. - -Lemma or4P : reflect [\/ b1, b2, b3 | b4] [|| b1, b2, b3 | b4]. -Proof. -case b1; first by constructor; constructor 1. -case b2; first by constructor; constructor 2. -case b3; first by constructor; constructor 3. -case b4; first by constructor; constructor 4. -by constructor; case. -Qed. - -Lemma nandP : reflect (~~ b1 \/ ~~ b2) (~~ (b1 && b2)). -Proof. by case b1; case b2; constructor; auto; case; auto. Qed. - -Lemma norP : reflect (~~ b1 /\ ~~ b2) (~~ (b1 || b2)). -Proof. by case b1; case b2; constructor; auto; case; auto. Qed. - -Lemma implyP : reflect (b1 -> b2) (b1 ==> b2). -Proof. by case b1; case b2; constructor; auto. Qed. - -End ReflectConnectives. - -Arguments idP {b1}. -Arguments idPn {b1}. -Arguments negP {b1}. -Arguments negPn {b1}. -Arguments negPf {b1}. -Arguments andP {b1 b2}. -Arguments and3P {b1 b2 b3}. -Arguments and4P {b1 b2 b3 b4}. -Arguments and5P {b1 b2 b3 b4 b5}. -Arguments orP {b1 b2}. -Arguments or3P {b1 b2 b3}. -Arguments or4P {b1 b2 b3 b4}. -Arguments nandP {b1 b2}. -Arguments norP {b1 b2}. -Arguments implyP {b1 b2}. -Prenex Implicits idP idPn negP negPn negPf. -Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. - -(** Shorter, more systematic names for the boolean connectives laws. **) - -Lemma andTb : left_id true andb. Proof. by []. Qed. -Lemma andFb : left_zero false andb. Proof. by []. Qed. -Lemma andbT : right_id true andb. Proof. by case. Qed. -Lemma andbF : right_zero false andb. Proof. by case. Qed. -Lemma andbb : idempotent andb. Proof. by case. Qed. -Lemma andbC : commutative andb. Proof. by do 2!case. Qed. -Lemma andbA : associative andb. Proof. by do 3!case. Qed. -Lemma andbCA : left_commutative andb. Proof. by do 3!case. Qed. -Lemma andbAC : right_commutative andb. Proof. by do 3!case. Qed. -Lemma andbACA : interchange andb andb. Proof. by do 4!case. Qed. - -Lemma orTb : forall b, true || b. Proof. by []. Qed. -Lemma orFb : left_id false orb. Proof. by []. Qed. -Lemma orbT : forall b, b || true. Proof. by case. Qed. -Lemma orbF : right_id false orb. Proof. by case. Qed. -Lemma orbb : idempotent orb. Proof. by case. Qed. -Lemma orbC : commutative orb. Proof. by do 2!case. Qed. -Lemma orbA : associative orb. Proof. by do 3!case. Qed. -Lemma orbCA : left_commutative orb. Proof. by do 3!case. Qed. -Lemma orbAC : right_commutative orb. Proof. by do 3!case. Qed. -Lemma orbACA : interchange orb orb. Proof. by do 4!case. Qed. - -Lemma andbN b : b && ~~ b = false. Proof. by case: b. Qed. -Lemma andNb b : ~~ b && b = false. Proof. by case: b. Qed. -Lemma orbN b : b || ~~ b = true. Proof. by case: b. Qed. -Lemma orNb b : ~~ b || b = true. Proof. by case: b. Qed. - -Lemma andb_orl : left_distributive andb orb. Proof. by do 3!case. Qed. -Lemma andb_orr : right_distributive andb orb. Proof. by do 3!case. Qed. -Lemma orb_andl : left_distributive orb andb. Proof. by do 3!case. Qed. -Lemma orb_andr : right_distributive orb andb. Proof. by do 3!case. Qed. - -Lemma andb_idl (a b : bool) : (b -> a) -> a && b = b. -Proof. by case: a; case: b => // ->. Qed. -Lemma andb_idr (a b : bool) : (a -> b) -> a && b = a. -Proof. by case: a; case: b => // ->. Qed. -Lemma andb_id2l (a b c : bool) : (a -> b = c) -> a && b = a && c. -Proof. by case: a; case: b; case: c => // ->. Qed. -Lemma andb_id2r (a b c : bool) : (b -> a = c) -> a && b = c && b. -Proof. by case: a; case: b; case: c => // ->. Qed. - -Lemma orb_idl (a b : bool) : (a -> b) -> a || b = b. -Proof. by case: a; case: b => // ->. Qed. -Lemma orb_idr (a b : bool) : (b -> a) -> a || b = a. -Proof. by case: a; case: b => // ->. Qed. -Lemma orb_id2l (a b c : bool) : (~~ a -> b = c) -> a || b = a || c. -Proof. by case: a; case: b; case: c => // ->. Qed. -Lemma orb_id2r (a b c : bool) : (~~ b -> a = c) -> a || b = c || b. -Proof. by case: a; case: b; case: c => // ->. Qed. - -Lemma negb_and (a b : bool) : ~~ (a && b) = ~~ a || ~~ b. -Proof. by case: a; case: b. Qed. - -Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. -Proof. by case: a; case: b. Qed. - -(** Pseudo-cancellation -- i.e, absorption **) - -Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. -Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. -Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. -Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. - -(** Imply **) - -Lemma implybT b : b ==> true. Proof. by case: b. Qed. -Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. -Lemma implyFb b : false ==> b. Proof. by []. Qed. -Lemma implyTb b : (true ==> b) = b. Proof. by []. Qed. -Lemma implybb b : b ==> b. Proof. by case: b. Qed. - -Lemma negb_imply a b : ~~ (a ==> b) = a && ~~ b. -Proof. by case: a; case: b. Qed. - -Lemma implybE a b : (a ==> b) = ~~ a || b. -Proof. by case: a; case: b. Qed. - -Lemma implyNb a b : (~~ a ==> b) = a || b. -Proof. by case: a; case: b. Qed. - -Lemma implybN a b : (a ==> ~~ b) = (b ==> ~~ a). -Proof. by case: a; case: b. Qed. - -Lemma implybNN a b : (~~ a ==> ~~ b) = b ==> a. -Proof. by case: a; case: b. Qed. - -Lemma implyb_idl (a b : bool) : (~~ a -> b) -> (a ==> b) = b. -Proof. by case: a; case: b => // ->. Qed. -Lemma implyb_idr (a b : bool) : (b -> ~~ a) -> (a ==> b) = ~~ a. -Proof. by case: a; case: b => // ->. Qed. -Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). -Proof. by case: a; case: b; case: c => // ->. Qed. - -(** Addition (xor) **) - -Lemma addFb : left_id false addb. Proof. by []. Qed. -Lemma addbF : right_id false addb. Proof. by case. Qed. -Lemma addbb : self_inverse false addb. Proof. by case. Qed. -Lemma addbC : commutative addb. Proof. by do 2!case. Qed. -Lemma addbA : associative addb. Proof. by do 3!case. Qed. -Lemma addbCA : left_commutative addb. Proof. by do 3!case. Qed. -Lemma addbAC : right_commutative addb. Proof. by do 3!case. Qed. -Lemma addbACA : interchange addb addb. Proof. by do 4!case. Qed. -Lemma andb_addl : left_distributive andb addb. Proof. by do 3!case. Qed. -Lemma andb_addr : right_distributive andb addb. Proof. by do 3!case. Qed. -Lemma addKb : left_loop id addb. Proof. by do 2!case. Qed. -Lemma addbK : right_loop id addb. Proof. by do 2!case. Qed. -Lemma addIb : left_injective addb. Proof. by do 3!case. Qed. -Lemma addbI : right_injective addb. Proof. by do 3!case. Qed. - -Lemma addTb b : true (+) b = ~~ b. Proof. by []. Qed. -Lemma addbT b : b (+) true = ~~ b. Proof. by case: b. Qed. - -Lemma addbN a b : a (+) ~~ b = ~~ (a (+) b). -Proof. by case: a; case: b. Qed. -Lemma addNb a b : ~~ a (+) b = ~~ (a (+) b). -Proof. by case: a; case: b. Qed. - -Lemma addbP a b : reflect (~~ a = b) (a (+) b). -Proof. by case: a; case: b; constructor. Qed. -Arguments addbP {a b}. - -(** - Resolution tactic for blindly weeding out common terms from boolean - equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 - they will try to locate b1 in b3 and remove it. This can fail! **) - -Ltac bool_congr := - match goal with - | |- (?X1 && ?X2 = ?X3) => first - [ symmetry; rewrite -1?(andbC X1) -?(andbCA X1); congr 1 (andb X1); symmetry - | case: (X1); [ rewrite ?andTb ?andbT // | by rewrite ?andbF /= ] ] - | |- (?X1 || ?X2 = ?X3) => first - [ symmetry; rewrite -1?(orbC X1) -?(orbCA X1); congr 1 (orb X1); symmetry - | case: (X1); [ by rewrite ?orbT //= | rewrite ?orFb ?orbF ] ] - | |- (?X1 (+) ?X2 = ?X3) => - symmetry; rewrite -1?(addbC X1) -?(addbCA X1); congr 1 (addb X1); symmetry - | |- (~~ ?X1 = ?X2) => congr 1 negb - end. - - -(** - Predicates, i.e., packaged functions to bool. - - pred T, the basic type for predicates over a type T, is simply an alias - for T -> bool. - We actually distinguish two kinds of predicates, which we call applicative - and collective, based on the syntax used to test them at some x in T: - - For an applicative predicate P, one uses prefix syntax: - P x - Also, most operations on applicative predicates use prefix syntax as - well (e.g., predI P Q). - - For a collective predicate A, one uses infix syntax: - x \in A - and all operations on collective predicates use infix syntax as well - (e.g., #[#predI A & B#]#). - There are only two kinds of applicative predicates: - - pred T, the alias for T -> bool mentioned above - - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T - that auto-simplifies on application (see ssrfun). - On the other hand, the set of collective predicate types is open-ended via - - predType T, a Structure that can be used to put Canonical collective - predicate interpretation on other types, such as lists, tuples, - finite sets, etc. - Indeed, we define such interpretations for applicative predicate types, - which can therefore also be used with the infix syntax, e.g., - x \in predI P Q - Moreover these infix forms are convertible to their prefix counterpart - (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse - is not true, however; collective predicate types cannot, in general, be - used applicatively, because of restrictions on implicit coercions. - However, we do define an explicit generic coercion - - mem : forall (pT : predType), pT -> mem_pred T - where mem_pred T is a variant of simpl_pred T that preserves the infix - syntax, i.e., mem A x auto-simplifies to x \in A. - Indeed, the infix "collective" operators are notation for a prefix - operator with arguments of type mem_pred T or pred T, applied to coerced - collective predicates, e.g., - Notation "x \in A" := (in_mem x (mem A)). - This prevents the variability in the predicate type from interfering with - the application of generic lemmas. Moreover this also makes it much easier - to define generic lemmas, because the simplest type -- pred T -- can be - used as the type of generic collective predicates, provided one takes care - not to use it applicatively; this avoids the burden of having to declare a - different predicate type for each predicate parameter of each section or - lemma. - In detail, we ensure that the head normal form of mem A is always of the - eta-long MemPred (fun x => pA x) form, where pA is the pred interpretation of - A following its predType pT, i.e., the _expansion_ of topred A. For a pred T - evar ?P, (mem ?P) converts MemPred (fun x => ?P x), whose argument is a Miller - pattern and therefore always unify: unifying (mem A) with (mem ?P) always - yields ?P = pA, because the rigid constant MemPred aligns the unification. - Furthermore, we ensure pA is always either A or toP .... A where toP ... is - the expansion of @topred T pT, and toP is declared as a Coercion, so pA will - _display_ as A in either case, and the instances of @mem T (predPredType T) pA - appearing in the premises or right-hand side of a generic lemma parametrized - by ?P will be indistinguishable from @mem T pT A. - Users should take care not to inadvertently "strip" (mem A) down to the - coerced A, since this will expose the internal toP coercion: Coq could then - display terms A x that cannot be typed as such. The topredE lemma can be used - to restore the x \in A syntax in this case. While -topredE can conversely be - used to change x \in P into P x for an applicative P, it is safer to use the - inE, unfold_in or and memE lemmas instead, as they do not run the risk of - exposing internal coercions. As a consequence it is better to explicitly - cast a generic applicative predicate to simpl_pred using the SimplPred - constructor when it is used as a collective predicate (see, e.g., - Lemma eq_big in bigop). - We also sometimes "instantiate" the predType structure by defining a - coercion to the sort of the predPredType structure, conveniently denoted - {pred T}. This works better for types such as {set T} that have subtypes that - coerce to them, since the same coercion will be inserted by the application - of mem, or of any lemma that expects a generic collective predicates with - type {pred T} := pred_sort (predPredType T) = pred T; thus {pred T} should be - the preferred type for generic collective predicate parameters. - This device also lets us turn any Type aT : predArgType into the total - predicate over that type, i.e., fun _: aT => true. This allows us to write, - e.g., ##|'I_n| for the cardinal of the (finite) type of integers less than n. - **) - -(** Boolean predicates. *) - -Definition pred T := T -> bool. -Identity Coercion fun_of_pred : pred >-> Funclass. - -Definition subpred T (p1 p2 : pred T) := forall x : T, p1 x -> p2 x. - -(* Notation for some manifest predicates. *) - -Notation xpred0 := (fun=> false). -Notation xpredT := (fun=> true). -Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). -Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). -Notation xpredC := (fun (p : pred _) x => ~~ p x). -Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). -Notation xpreim := (fun f (p : pred _) x => p (f x)). - -(** The packed class interface for pred-like types. **) - -Structure predType T := - PredType {pred_sort :> Type; topred : pred_sort -> pred T}. - -Definition clone_pred T U := - fun pT & @pred_sort T pT -> U => - fun toP (pT' := @PredType T U toP) & phant_id pT' pT => pT'. -Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ id) : form_scope. - -Canonical predPredType T := PredType (@id (pred T)). -Canonical boolfunPredType T := PredType (@id (T -> bool)). - -(** The type of abstract collective predicates. - While {pred T} is contertible to pred T, it presents the pred_sort coercion - class, which crucially does _not_ coerce to Funclass. Term whose type P coerces - to {pred T} cannot be applied to arguments, but they _can_ be used as if P - had a canonical predType instance, as the coercion will be inserted if the - unification P =~= pred_sort ?pT fails, changing the problem into the trivial - {pred T} =~= pred_sort ?pT (solution ?pT := predPredType P). - Additional benefits of this approach are that any type coercing to P will - also inherit this behaviour, and that the coercion will be apparent in the - elaborated expression. The latter may be important if the coercion is also - a canonical structure projector - see mathcomp/fingroup/fingroup.v. The - main drawback of implementing predType by coercion in this way is that the - type of the value must be known when the unification constraint is imposed: - if we only register the constraint and then later discover later that the - expression had type P it will be too late of insert a coercion, whereas a - canonical instance of predType fo P would have solved the deferred constraint. - Finally, definitions, lemmas and sections should use type {pred T} for - their generic collective type parameters, as this will make it possible to - apply such definitions and lemmas directly to values of types that implement - predType by coercion to {pred T} (values of types that implement predType - without coercing to {pred T} will have to be coerced explicitly using topred). -**) -Notation "{ 'pred' T }" := (pred_sort (predPredType T)) : type_scope. - -(** The type of self-simplifying collective predicates. **) -Definition simpl_pred T := simpl_fun T bool. -Definition SimplPred {T} (p : pred T) : simpl_pred T := SimplFun p. - -(** Some simpl_pred constructors. **) - -Definition pred0 {T} := @SimplPred T xpred0. -Definition predT {T} := @SimplPred T xpredT. -Definition predI {T} (p1 p2 : pred T) := SimplPred (xpredI p1 p2). -Definition predU {T} (p1 p2 : pred T) := SimplPred (xpredU p1 p2). -Definition predC {T} (p : pred T) := SimplPred (xpredC p). -Definition predD {T} (p1 p2 : pred T) := SimplPred (xpredD p1 p2). -Definition preim {aT rT} (f : aT -> rT) (d : pred rT) := SimplPred (xpreim f d). - -Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) : fun_scope. -Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) : fun_scope. -Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] : fun_scope. -Notation "[ 'pred' x : T | E ]" := - (SimplPred (fun x : T => E%B)) (only parsing) : fun_scope. -Notation "[ 'pred' x : T | E1 & E2 ]" := - [pred x : T | E1 && E2 ] (only parsing) : fun_scope. - -(** Coercions for simpl_pred. - As simpl_pred T values are used both applicatively and collectively we - need simpl_pred to coerce to both pred T _and_ {pred T}. However it is - undesirable to have two distinct constants for what are essentially identical - coercion functions, as this confuses the SSReflect keyed matching algorithm. - While the Coq Coercion declarations appear to disallow such Coercion aliasing, - it is possible to work around this limitation with a combination of modules - and functors, which we do below. - In addition we also give a predType instance for simpl_pred, which will - be preferred to the {pred T} coercion to solve simpl_pred T =~= pred_sort ?pT - constraints; not however that the pred_of_simpl coercion _will_ be used - when a simpl_pred T is passed as a {pred T}, since the simplPredType T - structure for simpl_pred T is _not_ convertible to predPredType T. **) - -Module PredOfSimpl. -Definition coerce T (sp : simpl_pred T) : pred T := fun_of_simpl sp. -End PredOfSimpl. -Notation pred_of_simpl := PredOfSimpl.coerce. -Coercion pred_of_simpl : simpl_pred >-> pred. -Canonical simplPredType T := PredType (@pred_of_simpl T). - -Module Type PredSortOfSimplSignature. -Parameter coerce : forall T, simpl_pred T -> {pred T}. -End PredSortOfSimplSignature. -Module DeclarePredSortOfSimpl (PredSortOfSimpl : PredSortOfSimplSignature). -Coercion PredSortOfSimpl.coerce : simpl_pred >-> pred_sort. -End DeclarePredSortOfSimpl. -Module Export PredSortOfSimplCoercion := DeclarePredSortOfSimpl PredOfSimpl. - -(** Type to pred coercion. - This lets us use types of sort predArgType as a synonym for their universal - predicate. We define this predicate as a simpl_pred T rather than a pred T or - a {pred T} so that /= and inE reduce (T x) and x \in T to true, respectively. - Unfortunately, this can't be used for existing types like bool whose sort - is already fixed (at least, not without redefining bool, true, false and - all bool operations and lemmas); we provide syntax to recast a given type - in predArgType as a workaround. **) -Definition predArgType := Type. -Bind Scope type_scope with predArgType. -Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. -Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. -Notation "{ : T }" := (T%type : predArgType) : type_scope. - -(** Boolean relations. - Simplifying relations follow the coding pattern of 2-argument simplifying - functions: the simplifying type constructor is applied to the _last_ - argument. This design choice will let the in_simpl componenent of inE expand - membership in simpl_rel as well. We provide an explicit coercion to rel T - to avoid eta-expansion during coercion; this coercion self-simplifies so it - should be invisible. - **) - -Definition rel T := T -> pred T. -Identity Coercion fun_of_rel : rel >-> Funclass. - -Definition subrel T (r1 r2 : rel T) := forall x y : T, r1 x y -> r2 x y. - -Definition simpl_rel T := T -> simpl_pred T. - -Coercion rel_of_simpl T (sr : simpl_rel T) : rel T := fun x : T => sr x. -Arguments rel_of_simpl {T} sr x /. - -Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). -Notation xrelpre := (fun f (r : rel _) x y => r (f x) (f y)). - -Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). -Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). -Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). - -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. -Notation "[ 'rel' x y : T | E ]" := - (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. - -Lemma subrelUl T (r1 r2 : rel T) : subrel r1 (relU r1 r2). -Proof. by move=> x y r1xy; apply/orP; left. Qed. - -Lemma subrelUr T (r1 r2 : rel T) : subrel r2 (relU r1 r2). -Proof. by move=> x y r2xy; apply/orP; right. Qed. - -(** Variant of simpl_pred specialised to the membership operator. **) - -Variant mem_pred T := Mem of pred T. - -(** - We mainly declare pred_of_mem as a coercion so that it is not displayed. - Similarly to pred_of_simpl, it will usually not be inserted by type - inference, as all mem_pred mp =~= pred_sort ?pT unification problems will - be solve by the memPredType instance below; pred_of_mem will however - be used if a mem_pred T is used as a {pred T}, which is desirable as it - will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma - exception a generic collective predicate p : {pred T} and premise x \in P - will display a subgoal x \in A rathere than x \in mem A. - Conversely, pred_of_mem will _not_ if it is used id (mem A) is used - applicatively or as a pred T; there the simpl_of_mem coercion defined below - will be used, resulting in a subgoal that displays as mem A x by simplifies - to x \in A. - **) -Coercion pred_of_mem {T} mp : {pred T} := let: Mem p := mp in [eta p]. -Canonical memPredType T := PredType (@pred_of_mem T). - -Definition in_mem {T} (x : T) mp := pred_of_mem mp x. -Definition eq_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 = in_mem x mp2. -Definition sub_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 -> in_mem x mp2. - -Arguments in_mem {T} x mp : simpl never. -Typeclasses Opaque eq_mem. -Typeclasses Opaque sub_mem. - -(** The [simpl_of_mem; pred_of_simpl] path provides a new mem_pred >-> pred - coercion, but does _not_ override the pred_of_mem : mem_pred >-> pred_sort - explicit coercion declaration above. - **) -Coercion simpl_of_mem {T} mp := SimplPred (fun x : T => in_mem x mp). - -Lemma sub_refl T (mp : mem_pred T) : sub_mem mp mp. Proof. by []. Qed. -Arguments sub_refl {T mp} [x] mp_x. - -(** - It is essential to interlock the production of the Mem constructor inside - the branch of the predType match, to ensure that unifying mem A with - Mem [eta ?p] sets ?p := toP A (or ?p := P if toP = id and A = [eta P]), - rather than topred pT A, had we put mem A := Mem (topred A). -**) -Definition mem T (pT : predType T) : pT -> mem_pred T := - let: PredType toP := pT in fun A => Mem [eta toP A]. -Arguments mem {T pT} A : rename, simpl never. - -Notation "x \in A" := (in_mem x (mem A)) : bool_scope. -Notation "x \in A" := (in_mem x (mem A)) : bool_scope. -Notation "x \notin A" := (~~ (x \in A)) : bool_scope. -Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. -Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. - -Notation "[ 'mem' A ]" := - (pred_of_simpl (simpl_of_mem (mem A))) (only parsing) : fun_scope. - -Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) : fun_scope. -Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) : fun_scope. -Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) : fun_scope. -Notation "[ 'predC' A ]" := (predC [mem A]) : fun_scope. -Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) : fun_scope. -Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] : fun_scope. -Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] : fun_scope. -Notation "[ 'pred' x 'in' A | E1 & E2 ]" := - [pred x | x \in A & E1 && E2 ] : fun_scope. - -Notation "[ 'rel' x y 'in' A & B | E ]" := - [rel x y | (x \in A) && (y \in B) && E] : fun_scope. -Notation "[ 'rel' x y 'in' A & B ]" := - [rel x y | (x \in A) && (y \in B)] : fun_scope. -Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. -Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. - -(** Aliases of pred T that let us tag instances of simpl_pred as applicative - or collective, via bespoke coercions. This tagging will give control over - the simplification behaviour of inE and othe rewriting lemmas below. - For this control to work it is crucial that collective_of_simpl _not_ - be convertible to either applicative_of_simpl or pred_of_simpl. Indeed - they differ here by a commutattive conversion (of the match and lambda). - **) -Definition applicative_pred T := pred T. -Definition collective_pred T := pred T. -Coercion applicative_pred_of_simpl T (sp : simpl_pred T) : applicative_pred T := - fun_of_simpl sp. -Coercion collective_pred_of_simpl T (sp : simpl_pred T) : collective_pred T := - let: SimplFun p := sp in p. - -(** Explicit simplification rules for predicate application and membership. **) -Section PredicateSimplification. - -Variables T : Type. - -Implicit Types (p : pred T) (pT : predType T) (sp : simpl_pred T). -Implicit Types (mp : mem_pred T). - -(** - The following four bespoke structures provide fine-grained control over - matching the various predicate forms. While all four follow a common pattern - of using a canonical projection to match a particular form of predicate - (in pred T, simpl_pred, mem_pred and mem_pred, respectively), and display - the matched predicate in the structure type, each is in fact used for a - different, specific purpose: - - registered_applicative_pred: this user-facing structure is used to - declare values of type pred T meant to be used applicatively. The - structure parameter merely displays this same value, and is used to avoid - undesirable, visible occurrence of the structure in the right hand side - of rewrite rules such as app_predE. - There is a canonical instance of registered_applicative_pred for values - of the applicative_of_simpl coercion, which handles the - Definition Apred : applicative_pred T := [pred x | ...] idiom. - This instance is mainly intended for the in_applicative component of inE, - in conjunction with manifest_mem_pred and applicative_mem_pred. - - manifest_simpl_pred: the only instance of this structure matches manifest - simpl_pred values of the form SimplPred p, displaying p in the structure - type. This structure is used in in_simpl to detect and selectively expand - collective predicates of this form. An explicit SimplPred p pattern would - _NOT_ work for this purpose, as then the left-hand side of in_simpl would - reduce to in_mem ?x (Mem [eta ?p]) and would thus match _any_ instance - of \in, not just those arising from a manifest simpl_pred. - - manifest_mem_pred: similar to manifest_simpl_pred, the one instance of this - structure matches manifest mem_pred values of the form Mem [eta ?p]. The - purpose is different however: to match and display in ?p the actual - predicate appearing in an ... \in ... expression matched by the left hand - side of the in_applicative component of inE; then - - applicative_mem_pred is a telescope refinement of manifest_mem_pred p with - a default constructor that checks that the predicate p is the value of a - registered_applicative_pred; any unfolding occurring during this check - does _not_ affect the value of p passed to in_applicative, since that - has been fixed earlier by the manifest_mem_pred match. In particular the - definition of a predicate using the applicative_pred_of_simpl idiom above - will not be expanded - this very case is the reason in_applicative uses - a mem_pred telescope in its left hand side. The more straightforward - ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) - with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] - rather than ?p := Apred in the example above. - Also note that the in_applicative component of inE must be come before the - in_simpl one, as the latter also matches terms of the form x \in Apred. - Finally, no component of inE matches x \in Acoll, when - Definition Acoll : collective_pred T := [pred x | ...]. - as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) - -Structure registered_applicative_pred p := RegisteredApplicativePred { - applicative_pred_value :> pred T; - _ : applicative_pred_value = p -}. -Definition ApplicativePred p := RegisteredApplicativePred (erefl p). -Canonical applicative_pred_applicative sp := - ApplicativePred (applicative_pred_of_simpl sp). - -Structure manifest_simpl_pred p := ManifestSimplPred { - simpl_pred_value :> simpl_pred T; - _ : simpl_pred_value = SimplPred p -}. -Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). - -Structure manifest_mem_pred p := ManifestMemPred { - mem_pred_value :> mem_pred T; - _ : mem_pred_value = Mem [eta p] -}. -Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). - -Structure applicative_mem_pred p := - ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. -Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := - [eta @ApplicativeMemPred ap]. - -Lemma mem_topred pT (pp : pT) : mem (topred pp) = mem pp. -Proof. by case: pT pp. Qed. - -Lemma topredE pT x (pp : pT) : topred pp x = (x \in pp). -Proof. by rewrite -mem_topred. Qed. - -Lemma app_predE x p (ap : registered_applicative_pred p) : ap x = (x \in p). -Proof. by case: ap => _ /= ->. Qed. - -Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. -Proof. by case: amp => -[_ /= ->]. Qed. - -Lemma in_collective x p (msp : manifest_simpl_pred p) : - (x \in collective_pred_of_simpl msp) = p x. -Proof. by case: msp => _ /= ->. Qed. - -Lemma in_simpl x p (msp : manifest_simpl_pred p) : - in_mem x (Mem [eta pred_of_simpl msp]) = p x. -Proof. by case: msp => _ /= ->. Qed. - -(** - Because of the explicit eta expansion in the left-hand side, this lemma - should only be used in the left-to-right direction. - **) -Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. -Proof. by []. Qed. - -Lemma simpl_predE p : SimplPred p =1 p. -Proof. by []. Qed. - -Definition inE := (in_applicative, in_simpl, simpl_predE). (* to be extended *) - -Lemma mem_simpl sp : mem sp = sp :> pred T. -Proof. by []. Qed. - -Definition memE := mem_simpl. (* could be extended *) - -Lemma mem_mem mp : - (mem mp = mp) * (mem (mp : simpl_pred T) = mp) * (mem (mp : pred T) = mp). -Proof. by case: mp. Qed. - -End PredicateSimplification. - -(** Qualifiers and keyed predicates. **) - -Variant qualifier (q : nat) T := Qualifier of {pred T}. - -Coercion has_quality n T (q : qualifier n T) : {pred T} := - fun x => let: Qualifier _ p := q in p x. -Arguments has_quality n {T}. - -Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. - -Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. -Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. -Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. -Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. -Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. -Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. -Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) : form_scope. -Notation "[ 'qualify' x : T | P ]" := - (Qualifier 0 (fun x : T => P%B)) (only parsing) : form_scope. -Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) : form_scope. -Notation "[ 'qualify' 'a' x : T | P ]" := - (Qualifier 1 (fun x : T => P%B)) (only parsing) : form_scope. -Notation "[ 'qualify' 'an' x | P ]" := - (Qualifier 2 (fun x => P%B)) : form_scope. -Notation "[ 'qualify' 'an' x : T | P ]" := - (Qualifier 2 (fun x : T => P%B)) (only parsing) : form_scope. - -(** Keyed predicates: support for property-bearing predicate interfaces. **) - -Section KeyPred. - -Variable T : Type. -#[universes(template)] -Variant pred_key (p : {pred T}) := DefaultPredKey. - -Variable p : {pred T}. -Structure keyed_pred (k : pred_key p) := - PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. - -Variable k : pred_key p. -Definition KeyedPred := @PackKeyedPred k p (frefl _). - -Variable k_p : keyed_pred k. -Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. - -(** - Instances that strip the mem cast; the first one has "pred_of_mem" as its - projection head value, while the second has "pred_of_simpl". The latter - has the side benefit of preempting accidental misdeclarations. - Note: pred_of_mem is the registered mem >-> pred_sort coercion, while - [simpl_of_mem; pred_of_simpl] is the mem >-> pred >=> Funclass coercion. We - must write down the coercions explicitly as the Canonical head constant - computation does not strip casts. **) -Canonical keyed_mem := - @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. -Canonical keyed_mem_simpl := - @PackKeyedPred k (pred_of_simpl (mem k_p)) keyed_predE. - -End KeyPred. - -Local Notation in_unkey x S := (x \in @unkey_pred _ S _ _) (only parsing). -Notation "x \in S" := (in_unkey x S) (only printing) : bool_scope. - -Section KeyedQualifier. - -Variables (T : Type) (n : nat) (q : qualifier n T). - -Structure keyed_qualifier (k : pred_key q) := - PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. -Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). -Variables (k : pred_key q) (k_q : keyed_qualifier k). -Fact keyed_qualifier_suproof : unkey_qualifier k_q =i q. -Proof. by case: k_q => /= _ ->. Qed. -Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. - -End KeyedQualifier. - -Notation "x \is A" := - (in_unkey x (has_quality 0 A)) (only printing) : bool_scope. -Notation "x \is 'a' A" := - (in_unkey x (has_quality 1 A)) (only printing) : bool_scope. -Notation "x \is 'an' A" := - (in_unkey x (has_quality 2 A)) (only printing) : bool_scope. - -Module DefaultKeying. - -Canonical default_keyed_pred T p := KeyedPred (@DefaultPredKey T p). -Canonical default_keyed_qualifier T n (q : qualifier n T) := - KeyedQualifier (DefaultPredKey q). - -End DefaultKeying. - -(** Skolemizing with conditions. **) - -Lemma all_tag_cond_dep I T (C : pred I) U : - (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> - {f : forall x, T x & forall x, C x -> U x (f x)}. -Proof. -move=> f0 fP; apply: all_tag (fun x y => C x -> U x y) _ => x. -by case Cx: (C x); [case/fP: Cx => y; exists y | exists (f0 x)]. -Qed. - -Lemma all_tag_cond I T (C : pred I) U : - T -> (forall x, C x -> {y : T & U x y}) -> - {f : I -> T & forall x, C x -> U x (f x)}. -Proof. by move=> y0; apply: all_tag_cond_dep. Qed. - -Lemma all_sig_cond_dep I T (C : pred I) P : - (forall x, T x) -> (forall x, C x -> {y : T x | P x y}) -> - {f : forall x, T x | forall x, C x -> P x (f x)}. -Proof. by move=> f0 /(all_tag_cond_dep f0)[f]; exists f. Qed. - -Lemma all_sig_cond I T (C : pred I) P : - T -> (forall x, C x -> {y : T | P x y}) -> - {f : I -> T | forall x, C x -> P x (f x)}. -Proof. by move=> y0; apply: all_sig_cond_dep. Qed. - -Section RelationProperties. - -(** - Caveat: reflexive should not be used to state lemmas, as auto and trivial - will not expand the constant. **) - -Variable T : Type. - -Variable R : rel T. - -Definition total := forall x y, R x y || R y x. -Definition transitive := forall y x z, R x y -> R y z -> R x z. - -Definition symmetric := forall x y, R x y = R y x. -Definition antisymmetric := forall x y, R x y && R y x -> x = y. -Definition pre_symmetric := forall x y, R x y -> R y x. - -Lemma symmetric_from_pre : pre_symmetric -> symmetric. -Proof. by move=> symR x y; apply/idP/idP; apply: symR. Qed. - -Definition reflexive := forall x, R x x. -Definition irreflexive := forall x, R x x = false. - -Definition left_transitive := forall x y, R x y -> R x =1 R y. -Definition right_transitive := forall x y, R x y -> R^~ x =1 R^~ y. - -Section PER. - -Hypotheses (symR : symmetric) (trR : transitive). - -Lemma sym_left_transitive : left_transitive. -Proof. by move=> x y Rxy z; apply/idP/idP; apply: trR; rewrite // symR. Qed. - -Lemma sym_right_transitive : right_transitive. -Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. - -End PER. - -(** - We define the equivalence property with prenex quantification so that it - can be localized using the {in ..., ..} form defined below. **) - -Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). - -Lemma equivalence_relP : equivalence_rel <-> reflexive /\ left_transitive. -Proof. -split=> [eqiR | [Rxx trR] x y z]; last by split=> [|/trR->]. -by split=> [x | x y Rxy z]; [rewrite (eqiR x x x) | rewrite (eqiR x y z)]. -Qed. - -End RelationProperties. - -Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). -Proof. by move=> trR x y z Ryx Rzy; apply: trR Rzy Ryx. Qed. - -(** Property localization **) - -Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). -Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). -Local Notation "{ 'all3' P }" := (forall x y z, P x y z: Prop) (at level 0). -Local Notation ph := (phantom _). - -Section LocalProperties. - -Variables T1 T2 T3 : Type. - -Variables (d1 : mem_pred T1) (d2 : mem_pred T2) (d3 : mem_pred T3). -Local Notation ph := (phantom Prop). - -Definition prop_for (x : T1) P & ph {all1 P} := P x. - -Lemma forE x P phP : @prop_for x P phP = P x. Proof. by []. Qed. - -Definition prop_in1 P & ph {all1 P} := - forall x, in_mem x d1 -> P x. - -Definition prop_in11 P & ph {all2 P} := - forall x y, in_mem x d1 -> in_mem y d2 -> P x y. - -Definition prop_in2 P & ph {all2 P} := - forall x y, in_mem x d1 -> in_mem y d1 -> P x y. - -Definition prop_in111 P & ph {all3 P} := - forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d3 -> P x y z. - -Definition prop_in12 P & ph {all3 P} := - forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d2 -> P x y z. - -Definition prop_in21 P & ph {all3 P} := - forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d2 -> P x y z. - -Definition prop_in3 P & ph {all3 P} := - forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d1 -> P x y z. - -Variable f : T1 -> T2. - -Definition prop_on1 Pf P & phantom T3 (Pf f) & ph {all1 P} := - forall x, in_mem (f x) d2 -> P x. - -Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := - forall x y, in_mem (f x) d2 -> in_mem (f y) d2 -> P x y. - -End LocalProperties. - -Definition inPhantom := Phantom Prop. -Definition onPhantom {T} P (x : T) := Phantom Prop (P x). - -Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := - exists2 g, prop_in1 d (inPhantom (cancel f g)) - & prop_on1 d (Phantom _ (cancel g)) (onPhantom (cancel g) f). - -Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := - exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) - & prop_in1 cd (inPhantom (cancel g f)). - -Notation "{ 'for' x , P }" := (prop_for x (inPhantom P)) : type_scope. -Notation "{ 'in' d , P }" := (prop_in1 (mem d) (inPhantom P)) : type_scope. -Notation "{ 'in' d1 & d2 , P }" := - (prop_in11 (mem d1) (mem d2) (inPhantom P)) : type_scope. -Notation "{ 'in' d & , P }" := (prop_in2 (mem d) (inPhantom P)) : type_scope. -Notation "{ 'in' d1 & d2 & d3 , P }" := - (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) : type_scope. -Notation "{ 'in' d1 & & d3 , P }" := - (prop_in21 (mem d1) (mem d3) (inPhantom P)) : type_scope. -Notation "{ 'in' d1 & d2 & , P }" := - (prop_in12 (mem d1) (mem d2) (inPhantom P)) : type_scope. -Notation "{ 'in' d & & , P }" := (prop_in3 (mem d) (inPhantom P)) : type_scope. -Notation "{ 'on' cd , P }" := - (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. - -Notation "{ 'on' cd & , P }" := - (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. - -Local Arguments onPhantom : clear scopes. -Notation "{ 'on' cd , P & g }" := - (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) : type_scope. -Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) : type_scope. -Notation "{ 'on' cd , 'bijective' f }" := - (bijective_on (mem cd) f) : type_scope. - -(** - Weakening and monotonicity lemmas for localized predicates. - Note that using these lemmas in backward reasoning will force expansion of - the predicate definition, as Coq needs to expose the quantifier to apply - these lemmas. We define a few specialized variants to avoid this for some - of the ssrfun predicates. **) - -Section LocalGlobal. - -Variables T1 T2 T3 : predArgType. -Variables (D1 : {pred T1}) (D2 : {pred T2}) (D3 : {pred T3}). -Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). -Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). -Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). -Variable P3 : T1 -> T2 -> T3 -> Prop. -Variable Q1 : (T1 -> T2) -> T1 -> Prop. -Variable Q1l : (T1 -> T2) -> T3 -> T1 -> Prop. -Variable Q2 : (T1 -> T2) -> T1 -> T1 -> Prop. - -Hypothesis sub1 : sub_mem d1 d1'. -Hypothesis sub2 : sub_mem d2 d2'. -Hypothesis sub3 : sub_mem d3 d3'. - -Lemma in1W : {all1 P1} -> {in D1, {all1 P1}}. -Proof. by move=> ? ?. Qed. -Lemma in2W : {all2 P2} -> {in D1 & D2, {all2 P2}}. -Proof. by move=> ? ?. Qed. -Lemma in3W : {all3 P3} -> {in D1 & D2 & D3, {all3 P3}}. -Proof. by move=> ? ?. Qed. - -Lemma in1T : {in T1, {all1 P1}} -> {all1 P1}. -Proof. by move=> ? ?; auto. Qed. -Lemma in2T : {in T1 & T2, {all2 P2}} -> {all2 P2}. -Proof. by move=> ? ?; auto. Qed. -Lemma in3T : {in T1 & T2 & T3, {all3 P3}} -> {all3 P3}. -Proof. by move=> ? ?; auto. Qed. - -Lemma sub_in1 (Ph : ph {all1 P1}) : prop_in1 d1' Ph -> prop_in1 d1 Ph. -Proof. by move=> allP x /sub1; apply: allP. Qed. - -Lemma sub_in11 (Ph : ph {all2 P2}) : prop_in11 d1' d2' Ph -> prop_in11 d1 d2 Ph. -Proof. by move=> allP x1 x2 /sub1 d1x1 /sub2; apply: allP. Qed. - -Lemma sub_in111 (Ph : ph {all3 P3}) : - prop_in111 d1' d2' d3' Ph -> prop_in111 d1 d2 d3 Ph. -Proof. by move=> allP x1 x2 x3 /sub1 d1x1 /sub2 d2x2 /sub3; apply: allP. Qed. - -Let allQ1 f'' := {all1 Q1 f''}. -Let allQ1l f'' h' := {all1 Q1l f'' h'}. -Let allQ2 f'' := {all2 Q2 f''}. - -Lemma on1W : allQ1 f -> {on D2, allQ1 f}. Proof. by move=> ? ?. Qed. - -Lemma on1lW : allQ1l f h -> {on D2, allQ1l f & h}. Proof. by move=> ? ?. Qed. - -Lemma on2W : allQ2 f -> {on D2 &, allQ2 f}. Proof. by move=> ? ?. Qed. - -Lemma on1T : {on T2, allQ1 f} -> allQ1 f. Proof. by move=> ? ?; auto. Qed. - -Lemma on1lT : {on T2, allQ1l f & h} -> allQ1l f h. -Proof. by move=> ? ?; auto. Qed. - -Lemma on2T : {on T2 &, allQ2 f} -> allQ2 f. -Proof. by move=> ? ?; auto. Qed. - -Lemma subon1 (Phf : ph (allQ1 f)) (Ph : ph (allQ1 f)) : - prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. -Proof. by move=> allQ x /sub2; apply: allQ. Qed. - -Lemma subon1l (Phf : ph (allQ1l f)) (Ph : ph (allQ1l f h)) : - prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. -Proof. by move=> allQ x /sub2; apply: allQ. Qed. - -Lemma subon2 (Phf : ph (allQ2 f)) (Ph : ph (allQ2 f)) : - prop_on2 d2' Phf Ph -> prop_on2 d2 Phf Ph. -Proof. by move=> allQ x y /sub2=> d2fx /sub2; apply: allQ. Qed. - -Lemma can_in_inj : {in D1, cancel f g} -> {in D1 &, injective f}. -Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. - -Lemma canLR_in x y : {in D1, cancel f g} -> y \in D1 -> x = f y -> g x = y. -Proof. by move=> fK D1y ->; rewrite fK. Qed. - -Lemma canRL_in x y : {in D1, cancel f g} -> x \in D1 -> f x = y -> x = g y. -Proof. by move=> fK D1x <-; rewrite fK. Qed. - -Lemma on_can_inj : {on D2, cancel f & g} -> {on D2 &, injective f}. -Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. - -Lemma canLR_on x y : {on D2, cancel f & g} -> f y \in D2 -> x = f y -> g x = y. -Proof. by move=> fK D2fy ->; rewrite fK. Qed. - -Lemma canRL_on x y : {on D2, cancel f & g} -> f x \in D2 -> f x = y -> x = g y. -Proof. by move=> fK D2fx <-; rewrite fK. Qed. - -Lemma inW_bij : bijective f -> {in D1, bijective f}. -Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. - -Lemma onW_bij : bijective f -> {on D2, bijective f}. -Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. - -Lemma inT_bij : {in T1, bijective f} -> bijective f. -Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. - -Lemma onT_bij : {on T2, bijective f} -> bijective f. -Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. - -Lemma sub_in_bij (D1' : pred T1) : - {subset D1 <= D1'} -> {in D1', bijective f} -> {in D1, bijective f}. -Proof. -by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. -Qed. - -Lemma subon_bij (D2' : pred T2) : - {subset D2 <= D2'} -> {on D2', bijective f} -> {on D2, bijective f}. -Proof. -by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. -Qed. - -End LocalGlobal. - -Lemma sub_in2 T d d' (P : T -> T -> Prop) : - sub_mem d d' -> forall Ph : ph {all2 P}, prop_in2 d' Ph -> prop_in2 d Ph. -Proof. by move=> /= sub_dd'; apply: sub_in11. Qed. - -Lemma sub_in3 T d d' (P : T -> T -> T -> Prop) : - sub_mem d d' -> forall Ph : ph {all3 P}, prop_in3 d' Ph -> prop_in3 d Ph. -Proof. by move=> /= sub_dd'; apply: sub_in111. Qed. - -Lemma sub_in12 T1 T d1 d1' d d' (P : T1 -> T -> T -> Prop) : - sub_mem d1 d1' -> sub_mem d d' -> - forall Ph : ph {all3 P}, prop_in12 d1' d' Ph -> prop_in12 d1 d Ph. -Proof. by move=> /= sub1 sub; apply: sub_in111. Qed. - -Lemma sub_in21 T T3 d d' d3 d3' (P : T -> T -> T3 -> Prop) : - sub_mem d d' -> sub_mem d3 d3' -> - forall Ph : ph {all3 P}, prop_in21 d' d3' Ph -> prop_in21 d d3 Ph. -Proof. by move=> /= sub sub3; apply: sub_in111. Qed. - -Lemma equivalence_relP_in T (R : rel T) (A : pred T) : - {in A & &, equivalence_rel R} - <-> {in A, reflexive R} /\ {in A &, forall x y, R x y -> {in A, R x =1 R y}}. -Proof. -split=> [eqiR | [Rxx trR] x y z *]; last by split=> [|/trR-> //]; apply: Rxx. -by split=> [x Ax|x y Ax Ay Rxy z Az]; [rewrite (eqiR x x) | rewrite (eqiR x y)]. -Qed. - -Section MonoHomoMorphismTheory. - -Variables (aT rT sT : Type) (f : aT -> rT) (g : rT -> aT). -Variables (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). - -Lemma monoW : {mono f : x / aP x >-> rP x} -> {homo f : x / aP x >-> rP x}. -Proof. by move=> hf x ax; rewrite hf. Qed. - -Lemma mono2W : - {mono f : x y / aR x y >-> rR x y} -> {homo f : x y / aR x y >-> rR x y}. -Proof. by move=> hf x y axy; rewrite hf. Qed. - -Hypothesis fgK : cancel g f. - -Lemma homoRL : - {homo f : x y / aR x y >-> rR x y} -> forall x y, aR (g x) y -> rR x (f y). -Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. - -Lemma homoLR : - {homo f : x y / aR x y >-> rR x y} -> forall x y, aR x (g y) -> rR (f x) y. -Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. - -Lemma homo_mono : - {homo f : x y / aR x y >-> rR x y} -> {homo g : x y / rR x y >-> aR x y} -> - {mono g : x y / rR x y >-> aR x y}. -Proof. -move=> mf mg x y; case: (boolP (rR _ _))=> [/mg //|]. -by apply: contraNF=> /mf; rewrite !fgK. -Qed. - -Lemma monoLR : - {mono f : x y / aR x y >-> rR x y} -> forall x y, rR (f x) y = aR x (g y). -Proof. by move=> mf x y; rewrite -{1}[y]fgK mf. Qed. - -Lemma monoRL : - {mono f : x y / aR x y >-> rR x y} -> forall x y, rR x (f y) = aR (g x) y. -Proof. by move=> mf x y; rewrite -{1}[x]fgK mf. Qed. - -Lemma can_mono : - {mono f : x y / aR x y >-> rR x y} -> {mono g : x y / rR x y >-> aR x y}. -Proof. by move=> mf x y /=; rewrite -mf !fgK. Qed. - -End MonoHomoMorphismTheory. - -Section MonoHomoMorphismTheory_in. - -Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : {pred aT}). -Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). - -Notation rD := [pred x | g x \in aD]. - -Lemma monoW_in : - {in aD &, {mono f : x y / aR x y >-> rR x y}} -> - {in aD &, {homo f : x y / aR x y >-> rR x y}}. -Proof. by move=> hf x y hx hy axy; rewrite hf. Qed. - -Lemma mono2W_in : - {in aD, {mono f : x / aP x >-> rP x}} -> - {in aD, {homo f : x / aP x >-> rP x}}. -Proof. by move=> hf x hx ax; rewrite hf. Qed. - -Hypothesis fgK_on : {on aD, cancel g & f}. - -Lemma homoRL_in : - {in aD &, {homo f : x y / aR x y >-> rR x y}} -> - {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. - -Lemma homoLR_in : - {in aD &, {homo f : x y / aR x y >-> rR x y}} -> - {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. - -Lemma homo_mono_in : - {in aD &, {homo f : x y / aR x y >-> rR x y}} -> - {in rD &, {homo g : x y / rR x y >-> aR x y}} -> - {in rD &, {mono g : x y / rR x y >-> aR x y}}. -Proof. -move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. -by apply: contraNF=> /mf; rewrite !fgK_on //; apply. -Qed. - -Lemma monoLR_in : - {in aD &, {mono f : x y / aR x y >-> rR x y}} -> - {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. -Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. - -Lemma monoRL_in : - {in aD &, {mono f : x y / aR x y >-> rR x y}} -> - {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. -Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. - -Lemma can_mono_in : - {in aD &, {mono f : x y / aR x y >-> rR x y}} -> - {in rD &, {mono g : x y / rR x y >-> aR x y}}. -Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. - -End MonoHomoMorphismTheory_in. diff --git a/plugins/ssr/ssrclasses.v b/plugins/ssr/ssrclasses.v deleted file mode 100644 index 0ae3f8c6a5..0000000000 --- a/plugins/ssr/ssrclasses.v +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -(** Compatibility layer for [under] and [setoid_rewrite]. - - Note: this file does not require [ssreflect]; it is both required by - [ssrsetoid] and required by [ssrunder]. - - Redefine [Coq.Classes.RelationClasses.Reflexive] here, so that doing - [Require Import ssreflect] does not [Require Import RelationClasses], - and conversely. **) - -Section Defs. - Context {A : Type}. - Class Reflexive (R : A -> A -> Prop) := - reflexivity : forall x : A, R x x. -End Defs. - -Register Reflexive as plugins.ssreflect.reflexive_type. -Register reflexivity as plugins.ssreflect.reflexive_proof. - -Instance eq_Reflexive {A : Type} : Reflexive (@eq A) := @eq_refl A. -Instance iff_Reflexive : Reflexive iff := iff_refl. diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v deleted file mode 100644 index bc4a57dedd..0000000000 --- a/plugins/ssr/ssreflect.v +++ /dev/null @@ -1,656 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -Require Import Bool. (* For bool_scope delimiter 'bool'. *) -Require Import ssrmatching. -Declare ML Module "ssreflect_plugin". - - -(** - This file is the Gallina part of the ssreflect plugin implementation. - Files that use the ssreflect plugin should always Require ssreflect and - either Import ssreflect or Import ssreflect.SsrSyntax. - Part of the contents of this file is technical and will only interest - advanced developers; in addition the following are defined: - #[#the str of v by f#]# == the Canonical s : str such that f s = v. - #[#the str of v#]# == the Canonical s : str that coerces to v. - argumentType c == the T such that c : forall x : T, P x. - returnType c == the R such that c : T -> R. - {type of c for s} == P s where c : forall x : T, P x. - nonPropType == an interface for non-Prop Types: a nonPropType coerces - to a Type, and only types that do _not_ have sort - Prop are canonical nonPropType instances. This is - useful for applied views (see mid-file comment). - notProp T == the nonPropType instance for type T. - phantom T v == singleton type with inhabitant Phantom T v. - phant T == singleton type with inhabitant Phant v. - =^~ r == the converse of rewriting rule r (e.g., in a - rewrite multirule). - unkeyed t == t, but treated as an unkeyed matching pattern by - the ssreflect matching algorithm. - nosimpl t == t, but on the right-hand side of Definition C := - nosimpl disables expansion of C by /=. - locked t == t, but locked t is not convertible to t. - locked_with k t == t, but not convertible to t or locked_with k' t - unless k = k' (with k : unit). Coq type-checking - will be much more efficient if locked_with with a - bespoke k is used for sealed definitions. - unlockable v == interface for sealed constant definitions of v. - Unlockable def == the unlockable that registers def : C = v. - #[#unlockable of C#]# == a clone for C of the canonical unlockable for the - definition of C (e.g., if it uses locked_with). - #[#unlockable fun C#]# == #[#unlockable of C#]# with the expansion forced to be - an explicit lambda expression. - -> The usage pattern for ADT operations is: - Definition foo_def x1 .. xn := big_foo_expression. - Fact foo_key : unit. Proof. by #[# #]#. Qed. - Definition foo := locked_with foo_key foo_def. - Canonical foo_unlockable := #[#unlockable fun foo#]#. - This minimizes the comparison overhead for foo, while still allowing - rewrite unlock to expose big_foo_expression. - More information about these definitions and their use can be found in the - ssreflect manual, and in specific comments below. **) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Module SsrSyntax. - -(** - Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the - parsing level 8, as a workaround for a notation grammar factoring problem. - Arguments of application-style notations (at level 10) should be declared - at level 8 rather than 9 or the camlp5 grammar will not factor properly. **) - -Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). -Reserved Notation "(* 69 *)" (at level 69). - -(** Non ambiguous keyword to check if the SsrSyntax module is imported **) -Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). - -Reserved Notation "<hidden n >" (at level 0, n at level 0, - format "<hidden n >"). -Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). - -End SsrSyntax. - -Export SsrMatchingSyntax. -Export SsrSyntax. - -(** Save primitive notation that will be overloaded. **) -Local Notation CoqGenericIf c vT vF := (if c then vT else vF) (only parsing). -Local Notation CoqGenericDependentIf c x R vT vF := - (if c as x return R then vT else vF) (only parsing). -Local Notation CoqCast x T := (x : T) (only parsing). - -(** Reserve notation that introduced in this file. **) -Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, - c, vT, vF at level 200, only parsing). -Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, - c, R, vT, vF at level 200, only parsing). -Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, - c, R, vT, vF at level 200, x ident, only parsing). - -Reserved Notation "x : T" (at level 100, right associativity, - format "'[hv' x '/ ' : T ']'"). -Reserved Notation "T : 'Type'" (at level 100, format "T : 'Type'"). -Reserved Notation "P : 'Prop'" (at level 100, format "P : 'Prop'"). - -Reserved Notation "[ 'the' sT 'of' v 'by' f ]" (at level 0, - format "[ 'the' sT 'of' v 'by' f ]"). -Reserved Notation "[ 'the' sT 'of' v ]" (at level 0, - format "[ 'the' sT 'of' v ]"). -Reserved Notation "{ 'type' 'of' c 'for' s }" (at level 0, - format "{ 'type' 'of' c 'for' s }"). - -Reserved Notation "=^~ r" (at level 100, format "=^~ r"). - -Reserved Notation "[ 'unlockable' 'of' C ]" (at level 0, - format "[ 'unlockable' 'of' C ]"). -Reserved Notation "[ 'unlockable' 'fun' C ]" (at level 0, - format "[ 'unlockable' 'fun' C ]"). - -(** - To define notations for tactic in intro patterns. - When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) -Declare Scope ssripat_scope. -Delimit Scope ssripat_scope with ssripat. - -(** - Make the general "if" into a notation, so that we can override it below. - The notations are "only parsing" because the Coq decompiler will not - recognize the expansion of the boolean if; using the default printer - avoids a spurious trailing %%GEN_IF. **) - -Declare Scope general_if_scope. -Delimit Scope general_if_scope with GEN_IF. - -Notation "'if' c 'then' vT 'else' vF" := - (CoqGenericIf c vT vF) (only parsing) : general_if_scope. - -Notation "'if' c 'return' R 'then' vT 'else' vF" := - (CoqGenericDependentIf c c R vT vF) (only parsing) : general_if_scope. - -Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := - (CoqGenericDependentIf c x R vT vF) (only parsing) : general_if_scope. - -(** Force boolean interpretation of simple if expressions. **) - -Declare Scope boolean_if_scope. -Delimit Scope boolean_if_scope with BOOL_IF. - -Notation "'if' c 'return' R 'then' vT 'else' vF" := - (if c is true as c in bool return R then vT else vF) : boolean_if_scope. - -Notation "'if' c 'then' vT 'else' vF" := - (if c%bool is true as _ in bool return _ then vT else vF) : boolean_if_scope. - -Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := - (if c%bool is true as x in bool return R then vT else vF) : boolean_if_scope. - -Open Scope boolean_if_scope. - -(** - To allow a wider variety of notations without reserving a large number of - of identifiers, the ssreflect library systematically uses "forms" to - enclose complex mixfix syntax. A "form" is simply a mixfix expression - enclosed in square brackets and introduced by a keyword: - #[#keyword ... #]# - Because the keyword follows a bracket it does not need to be reserved. - Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq - Lists library) should be loaded before ssreflect so that their notations - do not mask all ssreflect forms. **) -Declare Scope form_scope. -Delimit Scope form_scope with FORM. -Open Scope form_scope. - -(** - Allow overloading of the cast (x : T) syntax, put whitespace around the - ":" symbol to avoid lexical clashes (and for consistency with the parsing - precedence of the notation, which binds less tightly than application), - and put printing boxes that print the type of a long definition on a - separate line rather than force-fit it at the right margin. **) -Notation "x : T" := (CoqCast x T) : core_scope. - -(** - Allow the casual use of notations like nat * nat for explicit Type - declarations. Note that (nat * nat : Type) is NOT equivalent to - (nat * nat)%%type, whose inferred type is legacy type "Set". **) -Notation "T : 'Type'" := (CoqCast T%type Type) (only parsing) : core_scope. -(** Allow similarly Prop annotation for, e.g., rewrite multirules. **) -Notation "P : 'Prop'" := (CoqCast P%type Prop) (only parsing) : core_scope. - -(** Constants for abstract: and #[#: name #]# intro pattern **) -Definition abstract_lock := unit. -Definition abstract_key := tt. - -Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := - let: tt := lock in statement. - -Declare Scope ssr_scope. -Notation "<hidden n >" := (abstract _ n _) : ssr_scope. -Notation "T (* n *)" := (abstract T n abstract_key) : ssr_scope. -Open Scope ssr_scope. - -Register abstract_lock as plugins.ssreflect.abstract_lock. -Register abstract_key as plugins.ssreflect.abstract_key. -Register abstract as plugins.ssreflect.abstract. - -(** Constants for tactic-views **) -Inductive external_view : Type := tactic_view of Type. - -(** - Syntax for referring to canonical structures: - #[#the struct_type of proj_val by proj_fun#]# - This form denotes the Canonical instance s of the Structure type - struct_type whose proj_fun projection is proj_val, i.e., such that - proj_fun s = proj_val. - Typically proj_fun will be A record field accessors of struct_type, but - this need not be the case; it can be, for instance, a field of a record - type to which struct_type coerces; proj_val will likewise be coerced to - the return type of proj_fun. In all but the simplest cases, proj_fun - should be eta-expanded to allow for the insertion of implicit arguments. - In the common case where proj_fun itself is a coercion, the "by" part - can be omitted entirely; in this case it is inferred by casting s to the - inferred type of proj_val. Obviously the latter can be fixed by using an - explicit cast on proj_val, and it is highly recommended to do so when the - return type intended for proj_fun is "Type", as the type inferred for - proj_val may vary because of sort polymorphism (it could be Set or Prop). - Note when using the #[#the _ of _ #]# form to generate a substructure from a - telescopes-style canonical hierarchy (implementing inheritance with - coercions), one should always project or coerce the value to the BASE - structure, because Coq will only find a Canonical derived structure for - the Canonical base structure -- not for a base structure that is specific - to proj_value. **) - -Module TheCanonical. - -#[universes(template)] -Variant put vT sT (v1 v2 : vT) (s : sT) := Put. - -Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. - -Definition get_by vT sT of sT -> vT := @get vT sT. - -End TheCanonical. - -Import TheCanonical. (* Note: no export. *) - -Local Arguments get_by _%type_scope _%type_scope _ _ _ _. - -Notation "[ 'the' sT 'of' v 'by' f ]" := - (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) - (only parsing) : form_scope. - -Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*) s s) _)) - (only parsing) : form_scope. - -(** - The following are "format only" versions of the above notations. - We need to do this to prevent the formatter from being be thrown off by - application collapsing, coercion insertion and beta reduction in the right - hand side of the notations above. **) - -Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) - (only printing) : form_scope. - -Notation "[ 'the' sT 'of' v ]" := (@get _ sT v _ _) - (only printing) : form_scope. - -(** - We would like to recognize -Notation " #[# 'the' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) - (at level 0, format " #[# 'the' sT 'of' v : 'Type' #]#") : form_scope. - **) - -(** - Helper notation for canonical structure inheritance support. - This is a workaround for the poor interaction between delta reduction and - canonical projections in Coq's unification algorithm, by which transparent - definitions hide canonical instances, i.e., in - Canonical a_type_struct := @Struct a_type ... - Definition my_type := a_type. - my_type doesn't effectively inherit the struct structure from a_type. Our - solution is to redeclare the instance as follows - Canonical my_type_struct := Eval hnf in #[#struct of my_type#]#. - The special notation #[#str of _ #]# must be defined for each Strucure "str" - with constructor "Str", typically as follows - Definition clone_str s := - let: Str _ x y ... z := s return {type of Str for s} -> str in - fun k => k _ x y ... z. - Notation " #[# 'str' 'of' T 'for' s #]#" := (@clone_str s (@Str T)) - (at level 0, format " #[# 'str' 'of' T 'for' s #]#") : form_scope. - Notation " #[# 'str' 'of' T #]#" := (repack_str (fun x => @Str T x)) - (at level 0, format " #[# 'str' 'of' T #]#") : form_scope. - The notation for the match return predicate is defined below; the eta - expansion in the second form serves both to distinguish it from the first - and to avoid the delta reduction problem. - There are several variations on the notation and the definition of the - the "clone" function, for telescopes, mixin classes, and join (multiple - inheritance) classes. We describe a different idiom for clones in ssrfun; - it uses phantom types (see below) and static unification; see fintype and - ssralg for examples. **) - -Definition argumentType T P & forall x : T, P x := T. -Definition dependentReturnType T P & forall x : T, P x := P. -Definition returnType aT rT & aT -> rT := rT. - -Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) : type_scope. - -(** - A generic "phantom" type (actually, a unit type with a phantom parameter). - This type can be used for type definitions that require some Structure - on one of their parameters, to allow Coq to infer said structure so it - does not have to be supplied explicitly or via the " #[#the _ of _ #]#" notation - (the latter interacts poorly with other Notation). - The definition of a (co)inductive type with a parameter p : p_type, that - needs to use the operations of a structure - Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} - should be given as - Inductive indt_type (p : p_str) := Indt ... . - Definition indt_of (p : p_str) & phantom p_type p := indt_type p. - Notation "{ 'indt' p }" := (indt_of (Phantom p)). - Definition indt p x y ... z : {indt p} := @Indt p x y ... z. - Notation " #[# 'indt' x y ... z #]#" := (indt x y ... z). - That is, the concrete type and its constructor should be shadowed by - definitions that use a phantom argument to infer and display the true - value of p (in practice, the "indt" constructor often performs additional - functions, like "locking" the representation -- see below). - We also define a simpler version ("phant" / "Phant") of phantom for the - common case where p_type is Type. **) - -#[universes(template)] -Variant phantom T (p : T) := Phantom. -Arguments phantom : clear implicits. -Arguments Phantom : clear implicits. -#[universes(template)] -Variant phant (p : Type) := Phant. - -(** Internal tagging used by the implementation of the ssreflect elim. **) - -Definition protect_term (A : Type) (x : A) : A := x. - -Register protect_term as plugins.ssreflect.protect_term. - -(** - The ssreflect idiom for a non-keyed pattern: - - unkeyed t will match any subterm that unifies with t, regardless of - whether it displays the same head symbol as t. - - unkeyed t a b will match any application of a term f unifying with t, - to two arguments unifying with with a and b, respectively, regardless of - apparent head symbols. - - unkeyed x where x is a variable will match any subterm with the same - type as x (when x would raise the 'indeterminate pattern' error). **) - -Notation unkeyed x := (let flex := x in flex). - -(** Ssreflect converse rewrite rule rule idiom. **) -Definition ssr_converse R (r : R) := (Logic.I, r). -Notation "=^~ r" := (ssr_converse r) : form_scope. - -(** - Term tagging (user-level). - The ssreflect library uses four strengths of term tagging to restrict - convertibility during type checking: - nosimpl t simplifies to t EXCEPT in a definition; more precisely, given - Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by - the /= and //= switches unless it is in a forcing context (e.g., in - match foo t' with ... end, foo t' will be reduced if this allows the - match to be reduced). Note that nosimpl bar is simply notation for a - a term that beta-iota reduces to bar; hence rewrite /foo will replace - foo by bar, and rewrite -/foo will replace bar by foo. - CAVEAT: nosimpl should not be used inside a Section, because the end of - section "cooking" removes the iota redex. - locked t is provably equal to t, but is not convertible to t; 'locked' - provides support for selective rewriting, via the lock t : t = locked t - Lemma, and the ssreflect unlock tactic. - locked_with k t is equal but not convertible to t, much like locked t, - but supports explicit tagging with a value k : unit. This is used to - mitigate a flaw in the term comparison heuristic of the Coq kernel, - which treats all terms of the form locked t as equal and compares their - arguments recursively, leading to an exponential blowup of comparison. - For this reason locked_with should be used rather than locked when - defining ADT operations. The unlock tactic does not support locked_with - but the unlock rewrite rule does, via the unlockable interface. - we also use Module Type ascription to create truly opaque constants, - because simple expansion of constants to reveal an unreducible term - doubles the time complexity of a negative comparison. Such opaque - constants can be expanded generically with the unlock rewrite rule. - See the definition of card and subset in fintype for examples of this. **) - -Notation nosimpl t := (let: tt := tt in t). - -Lemma master_key : unit. Proof. exact tt. Qed. -Definition locked A := let: tt := master_key in fun x : A => x. - -Register master_key as plugins.ssreflect.master_key. -Register locked as plugins.ssreflect.locked. - -Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. - -(** Needed for locked predicates, in particular for eqType's. **) -Lemma not_locked_false_eq_true : locked false <> true. -Proof. unlock; discriminate. Qed. - -(** The basic closing tactic "done". **) -Ltac done := - trivial; hnf; intros; solve - [ do ![solve [trivial | apply: sym_equal; trivial] - | discriminate | contradiction | split] - | case not_locked_false_eq_true; assumption - | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. - -(** Quicker done tactic not including split, syntax: /0/ **) -Ltac ssrdone0 := - trivial; hnf; intros; solve - [ do ![solve [trivial | apply: sym_equal; trivial] - | discriminate | contradiction ] - | case not_locked_false_eq_true; assumption - | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. - -(** To unlock opaque constants. **) -#[universes(template)] -Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. -Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. - -Notation "[ 'unlockable' 'of' C ]" := - (@Unlockable _ _ C (unlock _)) : form_scope. - -Notation "[ 'unlockable' 'fun' C ]" := - (@Unlockable _ (fun _ => _) C (unlock _)) : form_scope. - -(** Generic keyed constant locking. **) - -(** The argument order ensures that k is always compared before T. **) -Definition locked_with k := let: tt := k in fun T x => x : T. - -(** - This can be used as a cheap alternative to cloning the unlockable instance - below, but with caution as unkeyed matching can be expensive. **) -Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. -Proof. by case: k. Qed. - -(** Intensionaly, this instance will not apply to locked u. **) -Canonical locked_with_unlockable T k x := - @Unlockable T x (locked_with k x) (locked_withE k x). - -(** More accurate variant of unlock, and safer alternative to locked_withE. **) -Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. -Proof. exact: unlock. Qed. - -(** The internal lemmas for the have tactics. **) - -Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. -Arguments ssr_have Plemma [Pgoal]. - -Definition ssr_have_let Pgoal Plemma step - (rest : let x : Plemma := step in Pgoal) : Pgoal := rest. -Arguments ssr_have_let [Pgoal]. - -Register ssr_have as plugins.ssreflect.ssr_have. -Register ssr_have_let as plugins.ssreflect.ssr_have_let. - -Definition ssr_suff Plemma Pgoal step (rest : Plemma) : Pgoal := step rest. -Arguments ssr_suff Plemma [Pgoal]. - -Definition ssr_wlog := ssr_suff. -Arguments ssr_wlog Plemma [Pgoal]. - -Register ssr_suff as plugins.ssreflect.ssr_suff. -Register ssr_wlog as plugins.ssreflect.ssr_wlog. - -(** Internal N-ary congruence lemmas for the congr tactic. **) - -Fixpoint nary_congruence_statement (n : nat) - : (forall B, (B -> B -> Prop) -> Prop) -> Prop := - match n with - | O => fun k => forall B, k B (fun x1 x2 : B => x1 = x2) - | S n' => - let k' A B e (f1 f2 : A -> B) := - forall x1 x2, x1 = x2 -> (e (f1 x1) (f2 x2) : Prop) in - fun k => forall A, nary_congruence_statement n' (fun B e => k _ (k' A B e)) - end. - -Lemma nary_congruence n (k := fun B e => forall y : B, (e y y : Prop)) : - nary_congruence_statement n k. -Proof. -have: k _ _ := _; rewrite {1}/k. -elim: n k => [|n IHn] k k_P /= A; first exact: k_P. -by apply: IHn => B e He; apply: k_P => f x1 x2 <-. -Qed. - -Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. -Proof. by move->. Qed. -Arguments ssr_congr_arrow : clear implicits. - -Register nary_congruence as plugins.ssreflect.nary_congruence. -Register ssr_congr_arrow as plugins.ssreflect.ssr_congr_arrow. - -(** View lemmas that don't use reflection. **) - -Section ApplyIff. - -Variables P Q : Prop. -Hypothesis eqPQ : P <-> Q. - -Lemma iffLR : P -> Q. Proof. by case: eqPQ. Qed. -Lemma iffRL : Q -> P. Proof. by case: eqPQ. Qed. - -Lemma iffLRn : ~P -> ~Q. Proof. by move=> nP tQ; case: nP; case: eqPQ tQ. Qed. -Lemma iffRLn : ~Q -> ~P. Proof. by move=> nQ tP; case: nQ; case: eqPQ tP. Qed. - -End ApplyIff. - -Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. -Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. - -(** - To focus non-ssreflect tactics on a subterm, eg vm_compute. - Usage: - elim/abstract_context: (pattern) => G defG. - vm_compute; rewrite {}defG {G}. - Note that vm_cast are not stored in the proof term - for reductions occurring in the context, hence - set here := pattern; vm_compute in (value of here) - blows up at Qed time. **) -Lemma abstract_context T (P : T -> Type) x : - (forall Q, Q = P -> Q x) -> P x. -Proof. by move=> /(_ P); apply. Qed. - -(*****************************************************************************) -(* Material for under/over (to rewrite under binders using "context lemmas") *) - -Require Export ssrunder. - -Hint Extern 0 (@Under_rel.Over_rel _ _ _ _) => - solve [ apply: Under_rel.over_rel_done ] : core. -Hint Resolve Under_rel.over_rel_done : core. - -Register Under_rel.Under_rel as plugins.ssreflect.Under_rel. -Register Under_rel.Under_rel_from_rel as plugins.ssreflect.Under_rel_from_rel. - -(** Closing rewrite rule *) -Definition over := over_rel. - -(** Closing tactic *) -Ltac over := - by [ apply: Under_rel.under_rel_done - | rewrite over - ]. - -(** Convenience rewrite rule to unprotect evars, e.g., to instantiate - them in another way than with reflexivity. *) -Definition UnderE := Under_relE. - -(*****************************************************************************) - -(** An interface for non-Prop types; used to avoid improper instantiation - of polymorphic lemmas with on-demand implicits when they are used as views. - For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. - Using move/Some_inj on a goal of the form Some n = Some 0 will fail: - SSReflect will interpret the view as @Some_inj ?T _top_assumption_ - since this is the well-typed application of the view with the minimal - number of inserted evars (taking ?T := Some n = Some 0), and then will - later complain that it cannot erase _top_assumption_ after having - abstracted the viewed assumption. Making x and y maximal implicits - would avoid this and force the intended @Some_inj nat x y _top_assumption_ - interpretation, but is undesirable as it makes it harder to use Some_inj - with the many SSReflect and MathComp lemmas that have an injectivity - premise. Specifying {T : nonPropType} solves this more elegantly, as then - (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. - **) - -Module NonPropType. - -(** Implementation notes: - We rely on three interface Structures: - - test_of r, the middle structure, performs the actual check: it has two - canonical instances whose 'condition' projection are maybeProj (?P : Prop) - and tt, and which set r := true and r := false, respectively. Unifying - condition (?t : test_of ?r) with maybeProj T will thus set ?r to true if - T is in Prop as the test_Prop T instance will apply, and otherwise simplify - maybeProp T to tt and use the test_negative instance and set ?r to false. - - call_of c r sets up a call to test_of on condition c with expected result r. - It has a default instance for its 'callee' projection to Type, which - sets c := maybeProj T and r := false when unifying with a type T. - - type is a telescope on call_of c r, which checks that unifying test_of ?r1 - with c indeed sets ?r1 := r; the type structure bundles the 'test' instance - and its 'result' value along with its call_of c r projection. The default - instance essentially provides eta-expansion for 'type'. This is only - essential for the first 'result' projection to bool; using the instance - for other projection merely avoids spurious delta expansions that would - spoil the notProp T notation. - In detail, unifying T =~= ?S with ?S : nonPropType, i.e., - (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) - first uses the default call instance with ?T := T to reduce (1) to - (2a) @condition (result ?S) (test ?S) =~= maybeProp T - (3) result ?S =~= false - (4) frame ?S =~= call T - along with some trivial universe-related checks which are irrelevant here. - Then the unification tries to use the test_Prop instance to reduce (2a) to - (6a) result ?S =~= true - (7a) ?P =~= T with ?P : Prop - (8a) test ?S =~= test_Prop ?P - Now the default 'check' instance with ?result := true resolves (6a) as - (9a) ?S := @check true ?test ?frame - Then (7a) can be solved precisely if T has sort at most (hence exactly) Prop, - and then (8a) is solved by the check instance, yielding ?test := test_Prop T, - and completing the solution of (2a), and _committing_ to it. But now (3) is - inconsistent with (9a), and this makes the entire problem (1) fails. - If on the othe hand T does not have sort Prop then (7a) fails and the - unification resorts to delta expanding (2a), which gives - (2b) @condition (result ?S) (test ?S) =~= tt - which is then reduced, using the test_negative instance, to - (6b) result ?S =~= false - (8b) test ?S =~= test_negative - Both are solved using the check default instance, as in the (2a) branch, giving - (9b) ?S := @check false test_negative ?frame - Then (3) and (4) are similarly soved using check, giving the final assignment - (9) ?S := notProp T - Observe that we _must_ perform the actual test unification on the arguments - of the initial canonical instance, and not on the instance itself as we do - in mathcomp/matrix and mathcomp/vector, because we want the unification to - fail when T has sort Prop. If both the test_of _and_ the result check - unifications were done as part of the structure telescope then the latter - would be a sub-problem of the former, and thus failing the check would merely - make the test_of unification backtrack and delta-expand and we would not get - failure. - **) - -Structure call_of (condition : unit) (result : bool) := Call {callee : Type}. -Definition maybeProp (T : Type) := tt. -Definition call T := Call (maybeProp T) false T. - -Structure test_of (result : bool) := Test {condition :> unit}. -Definition test_Prop (P : Prop) := Test true (maybeProp P). -Definition test_negative := Test false tt. - -Structure type := - Check {result : bool; test : test_of result; frame : call_of test result}. -Definition check result test frame := @Check result test frame. - -Module Exports. -Canonical call. -Canonical test_Prop. -Canonical test_negative. -Canonical check. -Notation nonPropType := type. -Coercion callee : call_of >-> Sortclass. -Coercion frame : type >-> call_of. -Notation notProp T := (@check false test_negative (call T)). -End Exports. - -End NonPropType. -Export NonPropType.Exports. diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v deleted file mode 100644 index dd847169b9..0000000000 --- a/plugins/ssr/ssrfun.v +++ /dev/null @@ -1,812 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -Require Import ssreflect. - - -(** - This file contains the basic definitions and notations for working with - functions. The definitions provide for: - - - Pair projections: - p.1 == first element of a pair - p.2 == second element of a pair - These notations also apply to p : P /\ Q, via an and >-> pair coercion. - - - Simplifying functions, beta-reduced by /= and simpl: - #[#fun : T => E#]# == constant function from type T that returns E - #[#fun x => E#]# == unary function - #[#fun x : T => E#]# == unary function with explicit domain type - #[#fun x y => E#]# == binary function - #[#fun x y : T => E#]# == binary function with common domain type - #[#fun (x : T) y => E#]# \ - #[#fun (x : xT) (y : yT) => E#]# | == binary function with (some) explicit, - #[#fun x (y : T) => E#]# / independent domain types for each argument - - - Partial functions using option type: - oapp f d ox == if ox is Some x returns f x, d otherwise - odflt d ox == if ox is Some x returns x, d otherwise - obind f ox == if ox is Some x returns f x, None otherwise - omap f ox == if ox is Some x returns Some (f x), None otherwise - - - Singleton types: - all_equal_to x0 == x0 is the only value in its type, so any such value - can be rewritten to x0. - - - A generic wrapper type: - wrapped T == the inductive type with values Wrap x for x : T. - unwrap w == the projection of w : wrapped T on T. - wrap x == the canonical injection of x : T into wrapped T; it is - equivalent to Wrap x, but is declared as a (default) - Canonical Structure, which lets the Coq HO unification - automatically expand x into unwrap (wrap x). The delta - reduction of wrap x to Wrap can be exploited to - introduce controlled nondeterminism in Canonical - Structure inference, as in the implementation of - the mxdirect predicate in matrix.v. - - - The empty type: - void == a notation for the Empty_set type of the standard library. - of_void T == the canonical injection void -> T. - - - Sigma types: - tag w == the i of w : {i : I & T i}. - tagged w == the T i component of w : {i : I & T i}. - Tagged T x == the {i : I & T i} with component x : T i. - tag2 w == the i of w : {i : I & T i & U i}. - tagged2 w == the T i component of w : {i : I & T i & U i}. - tagged2' w == the U i component of w : {i : I & T i & U i}. - Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. - sval u == the x of u : {x : T | P x}. - s2val u == the x of u : {x : T | P x & Q x}. - The properties of sval u, s2val u are given by lemmas svalP, s2valP, and - s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. - A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 - and pair, e.g., - have /all_sig#[#f fP#]# (x : T): {y : U | P y} by ... - yields an f : T -> U such that fP : forall x, P (f x). - - Identity functions: - id == NOTATION for the explicit identity function fun x => x. - @id T == notation for the explicit identity at type T. - idfun == an expression with a head constant, convertible to id; - idfun x simplifies to x. - @idfun T == the expression above, specialized to type T. - phant_id x y == the function type phantom _ x -> phantom _ y. - *** In addition to their casual use in functional programming, identity - functions are often used to trigger static unification as part of the - construction of dependent Records and Structures. For example, if we need - a structure sT over a type T, we take as arguments T, sT, and a "dummy" - function T -> sort sT: - Definition foo T sT & T -> sort sT := ... - We can avoid specifying sT directly by calling foo (@id T), or specify - the call completely while still ensuring the consistency of T and sT, by - calling @foo T sT idfun. The phant_id type allows us to extend this trick - to non-Type canonical projections. It also allows us to sidestep - dependent type constraints when building explicit records, e.g., given - Record r := R {x; y : T(x)}. - if we need to build an r from a given y0 while inferring some x0, such - that y0 : T(x0), we pose - Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. - Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking - the dependent type constraint y0 : T(x0). - - - Extensional equality for functions and relations (i.e. functions of two - arguments): - f1 =1 f2 == f1 x is equal to f2 x for all x. - f1 =1 f2 :> A == ... and f2 is explicitly typed. - f1 =2 f2 == f1 x y is equal to f2 x y for all x y. - f1 =2 f2 :> A == ... and f2 is explicitly typed. - - - Composition for total and partial functions: - f^~ y == function f with second argument specialised to y, - i.e., fun x => f x y - CAVEAT: conditional (non-maximal) implicit arguments - of f are NOT inserted in this context - @^~ x == application at x, i.e., fun f => f x - #[#eta f#]# == the explicit eta-expansion of f, i.e., fun x => f x - CAVEAT: conditional (non-maximal) implicit arguments - of f are NOT inserted in this context. - fun=> v := the constant function fun _ => v. - f1 \o f2 == composition of f1 and f2. - Note: (f1 \o f2) x simplifies to f1 (f2 x). - f1 \; f2 == categorical composition of f1 and f2. This expands to - to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). - pcomp f1 f2 == composition of partial functions f1 and f2. - - - - Properties of functions: - injective f <-> f is injective. - cancel f g <-> g is a left inverse of f / f is a right inverse of g. - pcancel f g <-> g is a left inverse of f where g is partial. - ocancel f g <-> g is a left inverse of f where f is partial. - bijective f <-> f is bijective (has a left and right inverse). - involutive f <-> f is involutive. - - - Properties for operations. - left_id e op <-> e is a left identity for op (e op x = x). - right_id e op <-> e is a right identity for op (x op e = x). - left_inverse e inv op <-> inv is a left inverse for op wrt identity e, - i.e., (inv x) op x = e. - right_inverse e inv op <-> inv is a right inverse for op wrt identity e - i.e., x op (i x) = e. - self_inverse e op <-> each x is its own op-inverse (x op x = e). - idempotent op <-> op is idempotent for op (x op x = x). - associative op <-> op is associative, i.e., - x op (y op z) = (x op y) op z. - commutative op <-> op is commutative (x op y = y op x). - left_commutative op <-> op is left commutative, i.e., - x op (y op z) = y op (x op z). - right_commutative op <-> op is right commutative, i.e., - (x op y) op z = (x op z) op y. - left_zero z op <-> z is a left zero for op (z op x = z). - right_zero z op <-> z is a right zero for op (x op z = z). - left_distributive op1 op2 <-> op1 distributes over op2 to the left: - (x op2 y) op1 z = (x op1 z) op2 (y op1 z). - right_distributive op1 op2 <-> op distributes over add to the right: - x op1 (y op2 z) = (x op1 z) op2 (x op1 z). - interchange op1 op2 <-> op1 and op2 satisfy an interchange law: - (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). - Note that interchange op op is a commutativity property. - left_injective op <-> op is injective in its left argument: - x op y = z op y -> x = z. - right_injective op <-> op is injective in its right argument: - x op y = x op z -> y = z. - left_loop inv op <-> op, inv obey the inverse loop left axiom: - (inv x) op (x op y) = y for all x, y, i.e., - op (inv x) is always a left inverse of op x - rev_left_loop inv op <-> op, inv obey the inverse loop reverse left - axiom: x op ((inv x) op y) = y, for all x, y. - right_loop inv op <-> op, inv obey the inverse loop right axiom: - (x op y) op (inv y) = x for all x, y. - rev_right_loop inv op <-> op, inv obey the inverse loop reverse right - axiom: (x op (inv y)) op y = x for all x, y. - Note that familiar "cancellation" identities like x + y - y = x or - x - y + y = x are respectively instances of right_loop and rev_right_loop - The corresponding lemmas will use the K and NK/VK suffixes, respectively. - - - Morphisms for functions and relations: - {morph f : x / a >-> r} <-> f is a morphism with respect to functions - (fun x => a) and (fun x => r); if r == R#[#x#]#, - this states that f a = R#[#f x#]# for all x. - {morph f : x / a} <-> f is a morphism with respect to the - function expression (fun x => a). This is - shorthand for {morph f : x / a >-> a}; note - that the two instances of a are often - interpreted at different types. - {morph f : x y / a >-> r} <-> f is a morphism with respect to functions - (fun x y => a) and (fun x y => r). - {morph f : x y / a} <-> f is a morphism with respect to the - function expression (fun x y => a). - {homo f : x / a >-> r} <-> f is a homomorphism with respect to the - predicates (fun x => a) and (fun x => r); - if r == R#[#x#]#, this states that a -> R#[#f x#]# - for all x. - {homo f : x / a} <-> f is a homomorphism with respect to the - predicate expression (fun x => a). - {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the - relations (fun x y => a) and (fun x y => r). - {homo f : x y / a} <-> f is a homomorphism with respect to the - relation expression (fun x y => a). - {mono f : x / a >-> r} <-> f is monotone with respect to projectors - (fun x => a) and (fun x => r); if r == R#[#x#]#, - this states that R#[#f x#]# = a for all x. - {mono f : x / a} <-> f is monotone with respect to the projector - expression (fun x => a). - {mono f : x y / a >-> r} <-> f is monotone with respect to relators - (fun x y => a) and (fun x y => r). - {mono f : x y / a} <-> f is monotone with respect to the relator - expression (fun x y => a). - - The file also contains some basic lemmas for the above concepts. - Lemmas relative to cancellation laws use some abbreviated suffixes: - K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). - LR - a lemma moving an operation from the left hand side of a relation to - the right hand side, like canLR: cancel g f -> x = g y -> f x = y. - RL - a lemma moving an operation from the right to the left, e.g., canRL. - Beware that the LR and RL orientations refer to an "apply" (back chaining) - usage; when using the same lemmas with "have" or "move" (forward chaining) - the directions will be reversed!. **) - - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -(** Parsing / printing declarations. *) -Reserved Notation "p .1" (at level 2, left associativity, format "p .1"). -Reserved Notation "p .2" (at level 2, left associativity, format "p .2"). -Reserved Notation "f ^~ y" (at level 10, y at level 8, no associativity, - format "f ^~ y"). -Reserved Notation "@^~ x" (at level 10, x at level 8, no associativity, - format "@^~ x"). -Reserved Notation "[ 'eta' f ]" (at level 0, format "[ 'eta' f ]"). -Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). - -Reserved Notation "[ 'fun' : T => E ]" (at level 0, - format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' x => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' x : T => E ]" (at level 0, - x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' x y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, - x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). -Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, - x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). - -Reserved Notation "f =1 g" (at level 70, no associativity). -Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). -Reserved Notation "f =2 g" (at level 70, no associativity). -Reserved Notation "f =2 g :> A" (at level 70, g at next level, A at level 90). -Reserved Notation "f \o g" (at level 50, format "f \o '/ ' g"). -Reserved Notation "f \; g" (at level 60, right associativity, - format "f \; '/ ' g"). - -Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a >-> r }"). -Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'morph' f : x / a }"). -Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). -Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'morph' f : x y / a }"). -Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a >-> r }"). -Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'homo' f : x / a }"). -Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). -Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y / a }"). -Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'homo' f : x y /~ a }"). -Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a >-> r }"). -Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, - x ident, format "{ 'mono' f : x / a }"). -Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). -Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y / a }"). -Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, - x ident, y ident, format "{ 'mono' f : x y /~ a }"). - -Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). -Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). - -(** - Syntax for defining auxiliary recursive function. - Usage: - Section FooDefinition. - Variables (g1 : T1) (g2 : T2). (globals) - Fixoint foo_auxiliary (a3 : T3) ... := - body, using #[#rec e3, ... #]# for recursive calls - where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. - Definition foo x y .. := #[#rec e1, ... #]#. - + proofs about foo - End FooDefinition. **) - -Reserved Notation "[ 'rec' a ]" (at level 0, - format "[ 'rec' a ]"). -Reserved Notation "[ 'rec' a , b ]" (at level 0, - format "[ 'rec' a , b ]"). -Reserved Notation "[ 'rec' a , b , c ]" (at level 0, - format "[ 'rec' a , b , c ]"). -Reserved Notation "[ 'rec' a , b , c , d ]" (at level 0, - format "[ 'rec' a , b , c , d ]"). -Reserved Notation "[ 'rec' a , b , c , d , e ]" (at level 0, - format "[ 'rec' a , b , c , d , e ]"). -Reserved Notation "[ 'rec' a , b , c , d , e , f ]" (at level 0, - format "[ 'rec' a , b , c , d , e , f ]"). -Reserved Notation "[ 'rec' a , b , c , d , e , f , g ]" (at level 0, - format "[ 'rec' a , b , c , d , e , f , g ]"). -Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h ]" (at level 0, - format "[ 'rec' a , b , c , d , e , f , g , h ]"). -Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i ]" (at level 0, - format "[ 'rec' a , b , c , d , e , f , g , h , i ]"). -Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i , j ]" (at level 0, - format "[ 'rec' a , b , c , d , e , f , g , h , i , j ]"). - -Declare Scope pair_scope. -Delimit Scope pair_scope with PAIR. -Open Scope pair_scope. - -(** Notations for pair/conjunction projections **) -Notation "p .1" := (fst p) : pair_scope. -Notation "p .2" := (snd p) : pair_scope. - -Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). - -Definition all_pair I T U (w : forall i : I, T i * U i) := - (fun i => (w i).1, fun i => (w i).2). - -(** - Complements on the option type constructor, used below to - encode partial functions. **) - -Module Option. - -Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x. - -Definition default T := apply (fun x : T => x). - -Definition bind aT rT (f : aT -> option rT) := apply f None. - -Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)). - -End Option. - -Notation oapp := Option.apply. -Notation odflt := Option.default. -Notation obind := Option.bind. -Notation omap := Option.map. -Notation some := (@Some _) (only parsing). - -(** Shorthand for some basic equality lemmas. **) - -Notation erefl := refl_equal. -Notation ecast i T e x := (let: erefl in _ = i := e return T in x). -Definition esym := sym_eq. -Definition nesym := sym_not_eq. -Definition etrans := trans_eq. -Definition congr1 := f_equal. -Definition congr2 := f_equal2. -(** Force at least one implicit when used as a view. **) -Prenex Implicits esym nesym. - -(** A predicate for singleton types. **) -Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. - -Lemma unitE : all_equal_to tt. Proof. by case. Qed. - -(** A generic wrapper type **) - -#[universes(template)] -Structure wrapped T := Wrap {unwrap : T}. -Canonical wrap T x := @Wrap T x. - -Prenex Implicits unwrap wrap Wrap. - -Declare Scope fun_scope. -Delimit Scope fun_scope with FUN. -Open Scope fun_scope. - -(** Notations for argument transpose **) -Notation "f ^~ y" := (fun x => f x y) : fun_scope. -Notation "@^~ x" := (fun f => f x) : fun_scope. - -(** - Definitions and notation for explicit functions with simplification, - i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) - -#[universes(template)] -Variant simpl_fun (aT rT : Type) := SimplFun of aT -> rT. - -Section SimplFun. - -Variables aT rT : Type. - -Definition fun_of_simpl (f : simpl_fun aT rT) := fun x => let: SimplFun lam := f in lam x. - -End SimplFun. - -Coercion fun_of_simpl : simpl_fun >-> Funclass. - -Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. -Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. -Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) : fun_scope. -Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) - (only parsing) : fun_scope. -Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) - (only parsing) : fun_scope. -Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) - (only parsing) : fun_scope. -Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) - (only parsing) : fun_scope. -Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" := (fun x : T => [fun y : U => E]) - (only parsing) : fun_scope. - -(** For delta functions in eqtype.v. **) -Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. - -(** - Extensional equality, for unary and binary functions, including syntactic - sugar. **) - -Section ExtensionalEquality. - -Variables A B C : Type. - -Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x. - -Definition eqrel (r s : C -> B -> A) : Prop := forall x y, r x y = s x y. - -Lemma frefl f : eqfun f f. Proof. by []. Qed. -Lemma fsym f g : eqfun f g -> eqfun g f. Proof. by move=> eq_fg x. Qed. - -Lemma ftrans f g h : eqfun f g -> eqfun g h -> eqfun f h. -Proof. by move=> eq_fg eq_gh x; rewrite eq_fg. Qed. - -Lemma rrefl r : eqrel r r. Proof. by []. Qed. - -End ExtensionalEquality. - -Typeclasses Opaque eqfun. -Typeclasses Opaque eqrel. - -Hint Resolve frefl rrefl : core. - -Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. -Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) : fun_scope. -Notation "f1 =2 f2" := (eqrel f1 f2) : fun_scope. -Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) : fun_scope. - -Section Composition. - -Variables A B C : Type. - -Definition comp (f : B -> A) (g : C -> B) x := f (g x). -Definition catcomp g f := comp f g. -Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). - -Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. -Proof. by move=> eq_ff' eq_gg' x; rewrite /comp eq_gg' eq_ff'. Qed. - -End Composition. - -Arguments comp {A B C} f g x /. -Arguments catcomp {A B C} g f x /. -Notation "f1 \o f2" := (comp f1 f2) : fun_scope. -Notation "f1 \; f2" := (catcomp f1 f2) : fun_scope. - -Notation "[ 'eta' f ]" := (fun x => f x) : fun_scope. - -Notation "'fun' => E" := (fun _ => E) : fun_scope. - -Notation id := (fun x => x). -Notation "@ 'id' T" := (fun x : T => x) (only parsing) : fun_scope. - -Definition idfun T x : T := x. -Arguments idfun {T} x /. - -Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. - -(** The empty type. **) - -Notation void := Empty_set. - -Definition of_void T (x : void) : T := match x with end. - -(** Strong sigma types. **) - -Section Tag. - -Variables (I : Type) (i : I) (T_ U_ : I -> Type). - -Definition tag := projT1. -Definition tagged : forall w, T_(tag w) := @projT2 I [eta T_]. -Definition Tagged x := @existT I [eta T_] i x. - -Definition tag2 (w : @sigT2 I T_ U_) := let: existT2 _ _ i _ _ := w in i. -Definition tagged2 w : T_(tag2 w) := let: existT2 _ _ _ x _ := w in x. -Definition tagged2' w : U_(tag2 w) := let: existT2 _ _ _ _ y := w in y. -Definition Tagged2 x y := @existT2 I [eta T_] [eta U_] i x y. - -End Tag. - -Arguments Tagged [I i]. -Arguments Tagged2 [I i]. -Prenex Implicits tag tagged Tagged tag2 tagged2 tagged2' Tagged2. - -Coercion tag_of_tag2 I T_ U_ (w : @sigT2 I T_ U_) := - Tagged (fun i => T_ i * U_ i)%type (tagged2 w, tagged2' w). - -Lemma all_tag I T U : - (forall x : I, {y : T x & U x y}) -> - {f : forall x, T x & forall x, U x (f x)}. -Proof. by move=> fP; exists (fun x => tag (fP x)) => x; case: (fP x). Qed. - -Lemma all_tag2 I T U V : - (forall i : I, {y : T i & U i y & V i y}) -> - {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. -Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. - -(** Refinement types. **) - -(** Prenex Implicits and renaming. **) -Notation sval := (@proj1_sig _ _). -Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). - -Section Sig. - -Variables (T : Type) (P Q : T -> Prop). - -Lemma svalP (u : sig P) : P (sval u). Proof. by case: u. Qed. - -Definition s2val (u : sig2 P Q) := let: exist2 _ _ x _ _ := u in x. - -Lemma s2valP u : P (s2val u). Proof. by case: u. Qed. - -Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed. - -End Sig. - -Prenex Implicits svalP s2val s2valP s2valP'. - -Coercion tag_of_sig I P (u : @sig I P) := Tagged P (svalP u). - -Coercion sig_of_sig2 I P Q (u : @sig2 I P Q) := - exist (fun i => P i /\ Q i) (s2val u) (conj (s2valP u) (s2valP' u)). - -Lemma all_sig I T P : - (forall x : I, {y : T x | P x y}) -> - {f : forall x, T x | forall x, P x (f x)}. -Proof. by case/all_tag=> f; exists f. Qed. - -Lemma all_sig2 I T P Q : - (forall x : I, {y : T x | P x y & Q x y}) -> - {f : forall x, T x | forall x, P x (f x) & forall x, Q x (f x)}. -Proof. by case/all_sig=> f /all_pair[]; exists f. Qed. - -Section Morphism. - -Variables (aT rT sT : Type) (f : aT -> rT). - -(** Morphism property for unary and binary functions **) -Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). -Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). - -(** Homomorphism property for unary and binary relations **) -Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). -Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := - forall x y, aR x y -> rR (f x) (f y). - -(** Stability property for unary and binary relations **) -Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. -Definition monomorphism_2 (aR rR : _ -> _ -> sT) := - forall x y, rR (f x) (f y) = aR x y. - -End Morphism. - -Notation "{ 'morph' f : x / a >-> r }" := - (morphism_1 f (fun x => a) (fun x => r)) : type_scope. -Notation "{ 'morph' f : x / a }" := - (morphism_1 f (fun x => a) (fun x => a)) : type_scope. -Notation "{ 'morph' f : x y / a >-> r }" := - (morphism_2 f (fun x y => a) (fun x y => r)) : type_scope. -Notation "{ 'morph' f : x y / a }" := - (morphism_2 f (fun x y => a) (fun x y => a)) : type_scope. -Notation "{ 'homo' f : x / a >-> r }" := - (homomorphism_1 f (fun x => a) (fun x => r)) : type_scope. -Notation "{ 'homo' f : x / a }" := - (homomorphism_1 f (fun x => a) (fun x => a)) : type_scope. -Notation "{ 'homo' f : x y / a >-> r }" := - (homomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. -Notation "{ 'homo' f : x y / a }" := - (homomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. -Notation "{ 'homo' f : x y /~ a }" := - (homomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. -Notation "{ 'mono' f : x / a >-> r }" := - (monomorphism_1 f (fun x => a) (fun x => r)) : type_scope. -Notation "{ 'mono' f : x / a }" := - (monomorphism_1 f (fun x => a) (fun x => a)) : type_scope. -Notation "{ 'mono' f : x y / a >-> r }" := - (monomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. -Notation "{ 'mono' f : x y / a }" := - (monomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. -Notation "{ 'mono' f : x y /~ a }" := - (monomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. - -(** - In an intuitionistic setting, we have two degrees of injectivity. The - weaker one gives only simplification, and the strong one provides a left - inverse (we show in `fintype' that they coincide for finite types). - We also define an intermediate version where the left inverse is only a - partial function. **) - -Section Injections. - -Variables (rT aT : Type) (f : aT -> rT). - -Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. - -Definition cancel g := forall x, g (f x) = x. - -Definition pcancel g := forall x, g (f x) = Some x. - -Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x. - -Lemma can_pcan g : cancel g -> pcancel (fun y => Some (g y)). -Proof. by move=> fK x; congr (Some _). Qed. - -Lemma pcan_inj g : pcancel g -> injective. -Proof. by move=> fK x y /(congr1 g); rewrite !fK => [[]]. Qed. - -Lemma can_inj g : cancel g -> injective. -Proof. by move/can_pcan; apply: pcan_inj. Qed. - -Lemma canLR g x y : cancel g -> x = f y -> g x = y. -Proof. by move=> fK ->. Qed. - -Lemma canRL g x y : cancel g -> f x = y -> x = g y. -Proof. by move=> fK <-. Qed. - -End Injections. - -Lemma Some_inj {T : nonPropType} : injective (@Some T). -Proof. by move=> x y []. Qed. - -Lemma of_voidK T : pcancel (of_void T) [fun _ => None]. -Proof. by case. Qed. - -(** cancellation lemmas for dependent type casts. **) -Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). -Proof. by case: y /. Qed. - -Lemma etrans_id T x y (eqxy : x = y :> T) : etrans (erefl x) eqxy = eqxy. -Proof. by case: y / eqxy. Qed. - -Section InjectionsTheory. - -Variables (A B C : Type) (f g : B -> A) (h : C -> B). - -Lemma inj_id : injective (@id A). -Proof. by []. Qed. - -Lemma inj_can_sym f' : cancel f f' -> injective f' -> cancel f' f. -Proof. by move=> fK injf' x; apply: injf'. Qed. - -Lemma inj_comp : injective f -> injective h -> injective (f \o h). -Proof. by move=> injf injh x y /injf; apply: injh. Qed. - -Lemma inj_compr : injective (f \o h) -> injective h. -Proof. by move=> injfh x y /(congr1 f) /injfh. Qed. - -Lemma can_comp f' h' : cancel f f' -> cancel h h' -> cancel (f \o h) (h' \o f'). -Proof. by move=> fK hK x; rewrite /= fK hK. Qed. - -Lemma pcan_pcomp f' h' : - pcancel f f' -> pcancel h h' -> pcancel (f \o h) (pcomp h' f'). -Proof. by move=> fK hK x; rewrite /pcomp fK /= hK. Qed. - -Lemma eq_inj : injective f -> f =1 g -> injective g. -Proof. by move=> injf eqfg x y; rewrite -2!eqfg; apply: injf. Qed. - -Lemma eq_can f' g' : cancel f f' -> f =1 g -> f' =1 g' -> cancel g g'. -Proof. by move=> fK eqfg eqfg' x; rewrite -eqfg -eqfg'. Qed. - -Lemma inj_can_eq f' : cancel f f' -> injective f' -> cancel g f' -> f =1 g. -Proof. by move=> fK injf' gK x; apply: injf'; rewrite fK. Qed. - -End InjectionsTheory. - -Section Bijections. - -Variables (A B : Type) (f : B -> A). - -Variant bijective : Prop := Bijective g of cancel f g & cancel g f. - -Hypothesis bijf : bijective. - -Lemma bij_inj : injective f. -Proof. by case: bijf => g fK _; apply: can_inj fK. Qed. - -Lemma bij_can_sym f' : cancel f' f <-> cancel f f'. -Proof. -split=> fK; first exact: inj_can_sym fK bij_inj. -by case: bijf => h _ hK x; rewrite -[x]hK fK. -Qed. - -Lemma bij_can_eq f' f'' : cancel f f' -> cancel f f'' -> f' =1 f''. -Proof. -by move=> fK fK'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym. -Qed. - -End Bijections. - -Section BijectionsTheory. - -Variables (A B C : Type) (f : B -> A) (h : C -> B). - -Lemma eq_bij : bijective f -> forall g, f =1 g -> bijective g. -Proof. by case=> f' fK f'K g eqfg; exists f'; eapply eq_can; eauto. Qed. - -Lemma bij_comp : bijective f -> bijective h -> bijective (f \o h). -Proof. -by move=> [f' fK f'K] [h' hK h'K]; exists (h' \o f'); apply: can_comp; auto. -Qed. - -Lemma bij_can_bij : bijective f -> forall f', cancel f f' -> bijective f'. -Proof. by move=> bijf; exists f; first by apply/(bij_can_sym bijf). Qed. - -End BijectionsTheory. - -Section Involutions. - -Variables (A : Type) (f : A -> A). - -Definition involutive := cancel f f. - -Hypothesis Hf : involutive. - -Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed. -Lemma inv_bij : bijective f. Proof. by exists f. Qed. - -End Involutions. - -Section OperationProperties. - -Variables S T R : Type. - -Section SopTisR. -Implicit Type op : S -> T -> R. -Definition left_inverse e inv op := forall x, op (inv x) x = e. -Definition right_inverse e inv op := forall x, op x (inv x) = e. -Definition left_injective op := forall x, injective (op^~ x). -Definition right_injective op := forall y, injective (op y). -End SopTisR. - - -Section SopTisS. -Implicit Type op : S -> T -> S. -Definition right_id e op := forall x, op x e = x. -Definition left_zero z op := forall x, op z x = z. -Definition right_commutative op := forall x y z, op (op x y) z = op (op x z) y. -Definition left_distributive op add := - forall x y z, op (add x y) z = add (op x z) (op y z). -Definition right_loop inv op := forall y, cancel (op^~ y) (op^~ (inv y)). -Definition rev_right_loop inv op := forall y, cancel (op^~ (inv y)) (op^~ y). -End SopTisS. - -Section SopTisT. -Implicit Type op : S -> T -> T. -Definition left_id e op := forall x, op e x = x. -Definition right_zero z op := forall x, op x z = z. -Definition left_commutative op := forall x y z, op x (op y z) = op y (op x z). -Definition right_distributive op add := - forall x y z, op x (add y z) = add (op x y) (op x z). -Definition left_loop inv op := forall x, cancel (op x) (op (inv x)). -Definition rev_left_loop inv op := forall x, cancel (op (inv x)) (op x). -End SopTisT. - -Section SopSisT. -Implicit Type op : S -> S -> T. -Definition self_inverse e op := forall x, op x x = e. -Definition commutative op := forall x y, op x y = op y x. -End SopSisT. - -Section SopSisS. -Implicit Type op : S -> S -> S. -Definition idempotent op := forall x, op x x = x. -Definition associative op := forall x y z, op x (op y z) = op (op x y) z. -Definition interchange op1 op2 := - forall x y z t, op1 (op2 x y) (op2 z t) = op2 (op1 x z) (op1 y t). -End SopSisS. - -End OperationProperties. - - - - - - - - - - diff --git a/plugins/ssr/ssrsetoid.v b/plugins/ssr/ssrsetoid.v deleted file mode 100644 index 7c5cd135fe..0000000000 --- a/plugins/ssr/ssrsetoid.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -(** Compatibility layer for [under] and [setoid_rewrite]. - - This file is intended to be required by [Require Import Setoid]. - - In particular, we can use the [under] tactic with other relations - than [eq] or [iff], e.g. a [RewriteRelation], by doing: - [Require Import ssreflect. Require Setoid.] - - This file's instances have priority 12 > other stdlib instances. - - (Note: this file could be skipped when porting [under] to stdlib2.) - *) - -Require Import ssrclasses. -Require Import ssrunder. -Require Import RelationClasses. -Require Import Relation_Definitions. - -(** Reconcile [Coq.Classes.RelationClasses.Reflexive] with - [Coq.ssr.ssrclasses.Reflexive] *) - -Instance compat_Reflexive : - forall {A} {R : relation A}, - RelationClasses.Reflexive R -> - ssrclasses.Reflexive R | 12. -Proof. now trivial. Qed. diff --git a/plugins/ssr/ssrunder.v b/plugins/ssr/ssrunder.v deleted file mode 100644 index 7c529a6133..0000000000 --- a/plugins/ssr/ssrunder.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) - -(** Constants for under/over, to rewrite under binders using "context lemmas" - - Note: this file does not require [ssreflect]; it is both required by - [ssrsetoid] and *exported* by [ssrunder]. - - This preserves the following feature: we can use [Setoid] without - requiring [ssreflect] and use [ssreflect] without requiring [Setoid]. -*) - -Require Import ssrclasses. - -Module Type UNDER_REL. -Parameter Under_rel : - forall (A : Type) (eqA : A -> A -> Prop), A -> A -> Prop. -Parameter Under_rel_from_rel : - forall (A : Type) (eqA : A -> A -> Prop) (x y : A), - @Under_rel A eqA x y -> eqA x y. -Parameter Under_relE : - forall (A : Type) (eqA : A -> A -> Prop), - @Under_rel A eqA = eqA. - -(** [Over_rel, over_rel, over_rel_done]: for "by rewrite over_rel" *) -Parameter Over_rel : - forall (A : Type) (eqA : A -> A -> Prop), A -> A -> Prop. -Parameter over_rel : - forall (A : Type) (eqA : A -> A -> Prop) (x y : A), - @Under_rel A eqA x y = @Over_rel A eqA x y. -Parameter over_rel_done : - forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), - @Over_rel A eqA x x. - -(** [under_rel_done]: for Ltac-style over *) -Parameter under_rel_done : - forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), - @Under_rel A eqA x x. -Notation "''Under[' x ]" := (@Under_rel _ _ x _) - (at level 8, format "''Under[' x ]", only printing). -End UNDER_REL. - -Module Export Under_rel : UNDER_REL. -Definition Under_rel (A : Type) (eqA : A -> A -> Prop) := - eqA. -Lemma Under_rel_from_rel : - forall (A : Type) (eqA : A -> A -> Prop) (x y : A), - @Under_rel A eqA x y -> eqA x y. -Proof. now trivial. Qed. -Lemma Under_relE (A : Type) (eqA : A -> A -> Prop) : - @Under_rel A eqA = eqA. -Proof. now trivial. Qed. -Definition Over_rel := Under_rel. -Lemma over_rel : - forall (A : Type) (eqA : A -> A -> Prop) (x y : A), - @Under_rel A eqA x y = @Over_rel A eqA x y. -Proof. now trivial. Qed. -Lemma over_rel_done : - forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), - @Over_rel A eqA x x. -Proof. now unfold Over_rel. Qed. -Lemma under_rel_done : - forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), - @Under_rel A eqA x x. -Proof. now trivial. Qed. -End Under_rel. diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v deleted file mode 100644 index 23a16615f5..0000000000 --- a/plugins/ssrmatching/ssrmatching.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -Declare ML Module "ssrmatching_plugin". - -Module SsrMatchingSyntax. - -(* Reserve the notation for rewrite patterns so that the user is not allowed *) -(* to declare it at a different level. *) -Reserved Notation "( a 'in' b )" (at level 0). -Reserved Notation "( a 'as' b )" (at level 0). -Reserved Notation "( a 'in' b 'in' c )" (at level 0). -Reserved Notation "( a 'as' b 'in' c )" (at level 0). - -Declare Scope ssrpatternscope. -Delimit Scope ssrpatternscope with pattern. - -(* Notation to define shortcuts for the "X in t" part of a pattern. *) -Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. - -(* Some shortcuts for recurrent "X in t" parts. *) -Notation RHS := (X in _ = X)%pattern. -Notation LHS := (X in X = _)%pattern. - -End SsrMatchingSyntax. - -Export SsrMatchingSyntax. - -Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p . |