diff options
Diffstat (limited to 'theories')
94 files changed, 25221 insertions, 8 deletions
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8ba17e38c8..9698737d33 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -465,7 +465,7 @@ Module EqNotations. | eq_refl => H' end) (at level 10, H' at level 10, - format "'[' 'rew' 'dependent' H in '/' H' ']'"). + format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' -> H 'in' H'" := (match H with | eq_refl => H' @@ -476,7 +476,7 @@ Module EqNotations. | eq_refl => H' end) (at level 10, H' at level 10, - format "'[' 'rew' 'dependent' <- H in '/' H' ']'"). + format "'[' 'rew' 'dependent' <- '/ ' H in '/' H' ']'"). Notation "'rew' 'dependent' [ 'fun' y p => P ] H 'in' H'" := (match H as p in (_ = y) return P with | eq_refl => H' diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index c00f8edcf7..d3e5ddcc8a 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -255,12 +255,6 @@ Qed. (** Equality of sigma types *) Import EqNotations. -Local Notation "'rew' 'dependent' H 'in' H'" - := (match H with - | eq_refl => H' - end) - (at level 10, H' at level 10, - format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). (** Equality for [sigT] *) Section sigT. diff --git a/theories/btauto/Algebra.v b/theories/btauto/Algebra.v new file mode 100644 index 0000000000..4a603f2c52 --- /dev/null +++ b/theories/btauto/Algebra.v @@ -0,0 +1,591 @@ +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/theories/btauto/Btauto.v b/theories/btauto/Btauto.v new file mode 100644 index 0000000000..d3331ccf89 --- /dev/null +++ b/theories/btauto/Btauto.v @@ -0,0 +1,3 @@ +Require Import Algebra Reflect. + +Declare ML Module "btauto_plugin". diff --git a/theories/btauto/Reflect.v b/theories/btauto/Reflect.v new file mode 100644 index 0000000000..867fe69550 --- /dev/null +++ b/theories/btauto/Reflect.v @@ -0,0 +1,411 @@ +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/theories/derive/Derive.v b/theories/derive/Derive.v new file mode 100644 index 0000000000..d1046ae79b --- /dev/null +++ b/theories/derive/Derive.v @@ -0,0 +1 @@ +Declare ML Module "derive_plugin". diff --git a/theories/extraction/ExtrHaskellBasic.v b/theories/extraction/ExtrHaskellBasic.v new file mode 100644 index 0000000000..d08a81da64 --- /dev/null +++ b/theories/extraction/ExtrHaskellBasic.v @@ -0,0 +1,17 @@ +(** 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/theories/extraction/ExtrHaskellNatInt.v b/theories/extraction/ExtrHaskellNatInt.v new file mode 100644 index 0000000000..267322d9ed --- /dev/null +++ b/theories/extraction/ExtrHaskellNatInt.v @@ -0,0 +1,15 @@ +(** 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/theories/extraction/ExtrHaskellNatInteger.v b/theories/extraction/ExtrHaskellNatInteger.v new file mode 100644 index 0000000000..4c5c71f58a --- /dev/null +++ b/theories/extraction/ExtrHaskellNatInteger.v @@ -0,0 +1,15 @@ +(** 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/theories/extraction/ExtrHaskellNatNum.v b/theories/extraction/ExtrHaskellNatNum.v new file mode 100644 index 0000000000..09b0444614 --- /dev/null +++ b/theories/extraction/ExtrHaskellNatNum.v @@ -0,0 +1,37 @@ +(** + * 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/theories/extraction/ExtrHaskellString.v b/theories/extraction/ExtrHaskellString.v new file mode 100644 index 0000000000..8c61f4e96b --- /dev/null +++ b/theories/extraction/ExtrHaskellString.v @@ -0,0 +1,62 @@ +(** + * 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/theories/extraction/ExtrHaskellZInt.v b/theories/extraction/ExtrHaskellZInt.v new file mode 100644 index 0000000000..0345ffc4e8 --- /dev/null +++ b/theories/extraction/ExtrHaskellZInt.v @@ -0,0 +1,26 @@ +(** 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/theories/extraction/ExtrHaskellZInteger.v b/theories/extraction/ExtrHaskellZInteger.v new file mode 100644 index 0000000000..f7f9e2f80d --- /dev/null +++ b/theories/extraction/ExtrHaskellZInteger.v @@ -0,0 +1,25 @@ +(** 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/theories/extraction/ExtrHaskellZNum.v b/theories/extraction/ExtrHaskellZNum.v new file mode 100644 index 0000000000..4141bd203f --- /dev/null +++ b/theories/extraction/ExtrHaskellZNum.v @@ -0,0 +1,23 @@ +(** + * 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/theories/extraction/ExtrOCamlFloats.v b/theories/extraction/ExtrOCamlFloats.v new file mode 100644 index 0000000000..1891772cc2 --- /dev/null +++ b/theories/extraction/ExtrOCamlFloats.v @@ -0,0 +1,61 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOCamlInt63.v b/theories/extraction/ExtrOCamlInt63.v new file mode 100644 index 0000000000..a2ee602313 --- /dev/null +++ b/theories/extraction/ExtrOCamlInt63.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlBasic.v b/theories/extraction/ExtrOcamlBasic.v new file mode 100644 index 0000000000..2f82b24862 --- /dev/null +++ b/theories/extraction/ExtrOcamlBasic.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlBigIntConv.v b/theories/extraction/ExtrOcamlBigIntConv.v new file mode 100644 index 0000000000..f8bc86d087 --- /dev/null +++ b/theories/extraction/ExtrOcamlBigIntConv.v @@ -0,0 +1,112 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlChar.v b/theories/extraction/ExtrOcamlChar.v new file mode 100644 index 0000000000..1e68365dd3 --- /dev/null +++ b/theories/extraction/ExtrOcamlChar.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlIntConv.v b/theories/extraction/ExtrOcamlIntConv.v new file mode 100644 index 0000000000..2de1906323 --- /dev/null +++ b/theories/extraction/ExtrOcamlIntConv.v @@ -0,0 +1,101 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlNatBigInt.v b/theories/extraction/ExtrOcamlNatBigInt.v new file mode 100644 index 0000000000..a66d6e41fd --- /dev/null +++ b/theories/extraction/ExtrOcamlNatBigInt.v @@ -0,0 +1,73 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlNatInt.v b/theories/extraction/ExtrOcamlNatInt.v new file mode 100644 index 0000000000..406a7f0d2b --- /dev/null +++ b/theories/extraction/ExtrOcamlNatInt.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlNativeString.v b/theories/extraction/ExtrOcamlNativeString.v new file mode 100644 index 0000000000..ec3da1e444 --- /dev/null +++ b/theories/extraction/ExtrOcamlNativeString.v @@ -0,0 +1,87 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlString.v b/theories/extraction/ExtrOcamlString.v new file mode 100644 index 0000000000..18c5ed3fe4 --- /dev/null +++ b/theories/extraction/ExtrOcamlString.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlZBigInt.v b/theories/extraction/ExtrOcamlZBigInt.v new file mode 100644 index 0000000000..c36ea50755 --- /dev/null +++ b/theories/extraction/ExtrOcamlZBigInt.v @@ -0,0 +1,91 @@ +(************************************************************************) +(* * 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/theories/extraction/ExtrOcamlZInt.v b/theories/extraction/ExtrOcamlZInt.v new file mode 100644 index 0000000000..c7343d2468 --- /dev/null +++ b/theories/extraction/ExtrOcamlZInt.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* * 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/theories/extraction/Extraction.v b/theories/extraction/Extraction.v new file mode 100644 index 0000000000..207c95247e --- /dev/null +++ b/theories/extraction/Extraction.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * 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/theories/funind/FunInd.v b/theories/funind/FunInd.v new file mode 100644 index 0000000000..d58b169154 --- /dev/null +++ b/theories/funind/FunInd.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* * 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/theories/funind/Recdef.v b/theories/funind/Recdef.v new file mode 100644 index 0000000000..cd3d69861f --- /dev/null +++ b/theories/funind/Recdef.v @@ -0,0 +1,52 @@ +(************************************************************************) +(* * 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/theories/ltac/Ltac.v b/theories/ltac/Ltac.v new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/theories/ltac/Ltac.v diff --git a/theories/micromega/DeclConstant.v b/theories/micromega/DeclConstant.v new file mode 100644 index 0000000000..7ad5e313e3 --- /dev/null +++ b/theories/micromega/DeclConstant.v @@ -0,0 +1,67 @@ +(************************************************************************) +(* * 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/theories/micromega/Env.v b/theories/micromega/Env.v new file mode 100644 index 0000000000..8f4d4726b6 --- /dev/null +++ b/theories/micromega/Env.v @@ -0,0 +1,101 @@ +(************************************************************************) +(* * 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/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v new file mode 100644 index 0000000000..2762bb6b32 --- /dev/null +++ b/theories/micromega/EnvRing.v @@ -0,0 +1,1101 @@ +(************************************************************************) +(* * 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/theories/micromega/Fourier.v b/theories/micromega/Fourier.v new file mode 100644 index 0000000000..0153de1dab --- /dev/null +++ b/theories/micromega/Fourier.v @@ -0,0 +1,5 @@ +Require Import Lra. +Require Export Fourier_util. + +#[deprecated(since = "8.9.0", note = "Use lra instead.")] +Ltac fourier := lra. diff --git a/theories/micromega/Fourier_util.v b/theories/micromega/Fourier_util.v new file mode 100644 index 0000000000..95fa5b88df --- /dev/null +++ b/theories/micromega/Fourier_util.v @@ -0,0 +1,31 @@ +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/theories/micromega/Lia.v b/theories/micromega/Lia.v new file mode 100644 index 0000000000..e53800d07d --- /dev/null +++ b/theories/micromega/Lia.v @@ -0,0 +1,39 @@ +(************************************************************************) +(* * 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/theories/micromega/Lqa.v b/theories/micromega/Lqa.v new file mode 100644 index 0000000000..25fb62cfad --- /dev/null +++ b/theories/micromega/Lqa.v @@ -0,0 +1,54 @@ +(************************************************************************) +(* * 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/theories/micromega/Lra.v b/theories/micromega/Lra.v new file mode 100644 index 0000000000..2403696696 --- /dev/null +++ b/theories/micromega/Lra.v @@ -0,0 +1,54 @@ +(************************************************************************) +(* * 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/theories/micromega/MExtraction.v b/theories/micromega/MExtraction.v new file mode 100644 index 0000000000..0e8c09ef1b --- /dev/null +++ b/theories/micromega/MExtraction.v @@ -0,0 +1,66 @@ +(************************************************************************) +(* * 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/theories/micromega/OrderedRing.v b/theories/micromega/OrderedRing.v new file mode 100644 index 0000000000..d5884d9c1c --- /dev/null +++ b/theories/micromega/OrderedRing.v @@ -0,0 +1,460 @@ +(************************************************************************) +(* * 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/theories/micromega/Psatz.v b/theories/micromega/Psatz.v new file mode 100644 index 0000000000..16ae24ba81 --- /dev/null +++ b/theories/micromega/Psatz.v @@ -0,0 +1,68 @@ +(************************************************************************) +(* * 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/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v new file mode 100644 index 0000000000..4a02d1d01e --- /dev/null +++ b/theories/micromega/QMicromega.v @@ -0,0 +1,220 @@ +(************************************************************************) +(* * 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/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v new file mode 100644 index 0000000000..0f7a02c2c9 --- /dev/null +++ b/theories/micromega/RMicromega.v @@ -0,0 +1,489 @@ +(************************************************************************) +(* * 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/theories/micromega/Refl.v b/theories/micromega/Refl.v new file mode 100644 index 0000000000..cd759029fa --- /dev/null +++ b/theories/micromega/Refl.v @@ -0,0 +1,152 @@ +(* -*- 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/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v new file mode 100644 index 0000000000..aa8876357a --- /dev/null +++ b/theories/micromega/RingMicromega.v @@ -0,0 +1,1134 @@ +(************************************************************************) +(* * 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/theories/micromega/Tauto.v b/theories/micromega/Tauto.v new file mode 100644 index 0000000000..a155207e2e --- /dev/null +++ b/theories/micromega/Tauto.v @@ -0,0 +1,1390 @@ +(************************************************************************) +(* * 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/theories/micromega/VarMap.v b/theories/micromega/VarMap.v new file mode 100644 index 0000000000..6db62e8401 --- /dev/null +++ b/theories/micromega/VarMap.v @@ -0,0 +1,79 @@ +(* -*- 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/theories/micromega/ZCoeff.v b/theories/micromega/ZCoeff.v new file mode 100644 index 0000000000..08f3f39204 --- /dev/null +++ b/theories/micromega/ZCoeff.v @@ -0,0 +1,175 @@ +(************************************************************************) +(* * 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/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v new file mode 100644 index 0000000000..9bedb47371 --- /dev/null +++ b/theories/micromega/ZMicromega.v @@ -0,0 +1,1743 @@ +(************************************************************************) +(* * 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/theories/micromega/Zify.v b/theories/micromega/Zify.v new file mode 100644 index 0000000000..18cd196148 --- /dev/null +++ b/theories/micromega/Zify.v @@ -0,0 +1,90 @@ +(************************************************************************) +(* * 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/theories/micromega/ZifyBool.v b/theories/micromega/ZifyBool.v new file mode 100644 index 0000000000..4060478363 --- /dev/null +++ b/theories/micromega/ZifyBool.v @@ -0,0 +1,278 @@ +(************************************************************************) +(* * 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/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v new file mode 100644 index 0000000000..d3f7f91074 --- /dev/null +++ b/theories/micromega/ZifyClasses.v @@ -0,0 +1,232 @@ +(************************************************************************) +(* * 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/theories/micromega/ZifyComparison.v b/theories/micromega/ZifyComparison.v new file mode 100644 index 0000000000..df75cf2c05 --- /dev/null +++ b/theories/micromega/ZifyComparison.v @@ -0,0 +1,82 @@ +(************************************************************************) +(* * 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/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v new file mode 100644 index 0000000000..edfb5a2a94 --- /dev/null +++ b/theories/micromega/ZifyInst.v @@ -0,0 +1,544 @@ +(************************************************************************) +(* * 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/theories/micromega/Ztac.v b/theories/micromega/Ztac.v new file mode 100644 index 0000000000..091f58a0ef --- /dev/null +++ b/theories/micromega/Ztac.v @@ -0,0 +1,140 @@ +(************************************************************************) +(* * 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/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v new file mode 100644 index 0000000000..896ee303cc --- /dev/null +++ b/theories/nsatz/Nsatz.v @@ -0,0 +1,525 @@ +(************************************************************************) +(* * 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/theories/omega/Omega.v b/theories/omega/Omega.v new file mode 100644 index 0000000000..4ceb530827 --- /dev/null +++ b/theories/omega/Omega.v @@ -0,0 +1,55 @@ +(************************************************************************) +(* * 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/theories/omega/OmegaLemmas.v b/theories/omega/OmegaLemmas.v new file mode 100644 index 0000000000..d2378569fc --- /dev/null +++ b/theories/omega/OmegaLemmas.v @@ -0,0 +1,307 @@ +(************************************************************************) +(* * 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/theories/omega/OmegaPlugin.v b/theories/omega/OmegaPlugin.v new file mode 100644 index 0000000000..303eb0527a --- /dev/null +++ b/theories/omega/OmegaPlugin.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* * 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/theories/omega/OmegaTactic.v b/theories/omega/OmegaTactic.v new file mode 100644 index 0000000000..303eb0527a --- /dev/null +++ b/theories/omega/OmegaTactic.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* * 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/theories/omega/PreOmega.v b/theories/omega/PreOmega.v new file mode 100644 index 0000000000..34533670f8 --- /dev/null +++ b/theories/omega/PreOmega.v @@ -0,0 +1,588 @@ +(************************************************************************) +(* * 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/theories/rtauto/Bintree.v b/theories/rtauto/Bintree.v new file mode 100644 index 0000000000..6b92445326 --- /dev/null +++ b/theories/rtauto/Bintree.v @@ -0,0 +1,385 @@ +(************************************************************************) +(* * 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/theories/rtauto/Rtauto.v b/theories/rtauto/Rtauto.v new file mode 100644 index 0000000000..2e9b4347b9 --- /dev/null +++ b/theories/rtauto/Rtauto.v @@ -0,0 +1,410 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Algebra_syntax.v b/theories/setoid_ring/Algebra_syntax.v new file mode 100644 index 0000000000..5f594d29cd --- /dev/null +++ b/theories/setoid_ring/Algebra_syntax.v @@ -0,0 +1,34 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/ArithRing.v b/theories/setoid_ring/ArithRing.v new file mode 100644 index 0000000000..727e99f0b4 --- /dev/null +++ b/theories/setoid_ring/ArithRing.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/BinList.v b/theories/setoid_ring/BinList.v new file mode 100644 index 0000000000..958832274b --- /dev/null +++ b/theories/setoid_ring/BinList.v @@ -0,0 +1,82 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Cring.v b/theories/setoid_ring/Cring.v new file mode 100644 index 0000000000..df0313a624 --- /dev/null +++ b/theories/setoid_ring/Cring.v @@ -0,0 +1,275 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Field.v b/theories/setoid_ring/Field.v new file mode 100644 index 0000000000..9ff07948df --- /dev/null +++ b/theories/setoid_ring/Field.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Field_tac.v b/theories/setoid_ring/Field_tac.v new file mode 100644 index 0000000000..a5390efc7f --- /dev/null +++ b/theories/setoid_ring/Field_tac.v @@ -0,0 +1,584 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Field_theory.v b/theories/setoid_ring/Field_theory.v new file mode 100644 index 0000000000..3736bc47a5 --- /dev/null +++ b/theories/setoid_ring/Field_theory.v @@ -0,0 +1,1819 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/InitialRing.v b/theories/setoid_ring/InitialRing.v new file mode 100644 index 0000000000..dc096554c8 --- /dev/null +++ b/theories/setoid_ring/InitialRing.v @@ -0,0 +1,894 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Integral_domain.v b/theories/setoid_ring/Integral_domain.v new file mode 100644 index 0000000000..f1394c51d5 --- /dev/null +++ b/theories/setoid_ring/Integral_domain.v @@ -0,0 +1,53 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/NArithRing.v b/theories/setoid_ring/NArithRing.v new file mode 100644 index 0000000000..8cda4ad714 --- /dev/null +++ b/theories/setoid_ring/NArithRing.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ncring.v b/theories/setoid_ring/Ncring.v new file mode 100644 index 0000000000..8f3de26272 --- /dev/null +++ b/theories/setoid_ring/Ncring.v @@ -0,0 +1,308 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ncring_initial.v b/theories/setoid_ring/Ncring_initial.v new file mode 100644 index 0000000000..e40ef6056d --- /dev/null +++ b/theories/setoid_ring/Ncring_initial.v @@ -0,0 +1,214 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ncring_polynom.v b/theories/setoid_ring/Ncring_polynom.v new file mode 100644 index 0000000000..048c8eecf9 --- /dev/null +++ b/theories/setoid_ring/Ncring_polynom.v @@ -0,0 +1,594 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ncring_tac.v b/theories/setoid_ring/Ncring_tac.v new file mode 100644 index 0000000000..65233873b1 --- /dev/null +++ b/theories/setoid_ring/Ncring_tac.v @@ -0,0 +1,328 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/RealField.v b/theories/setoid_ring/RealField.v new file mode 100644 index 0000000000..d83fcf3781 --- /dev/null +++ b/theories/setoid_ring/RealField.v @@ -0,0 +1,158 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ring.v b/theories/setoid_ring/Ring.v new file mode 100644 index 0000000000..35e308565f --- /dev/null +++ b/theories/setoid_ring/Ring.v @@ -0,0 +1,46 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ring_base.v b/theories/setoid_ring/Ring_base.v new file mode 100644 index 0000000000..36e7890fbb --- /dev/null +++ b/theories/setoid_ring/Ring_base.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v new file mode 100644 index 0000000000..092114ff0b --- /dev/null +++ b/theories/setoid_ring/Ring_polynom.v @@ -0,0 +1,1509 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v new file mode 100644 index 0000000000..0a14c0ee5c --- /dev/null +++ b/theories/setoid_ring/Ring_tac.v @@ -0,0 +1,472 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Ring_theory.v b/theories/setoid_ring/Ring_theory.v new file mode 100644 index 0000000000..dc45853458 --- /dev/null +++ b/theories/setoid_ring/Ring_theory.v @@ -0,0 +1,619 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Rings_Q.v b/theories/setoid_ring/Rings_Q.v new file mode 100644 index 0000000000..b3ed0be916 --- /dev/null +++ b/theories/setoid_ring/Rings_Q.v @@ -0,0 +1,41 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Rings_R.v b/theories/setoid_ring/Rings_R.v new file mode 100644 index 0000000000..ec91fa9e97 --- /dev/null +++ b/theories/setoid_ring/Rings_R.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/Rings_Z.v b/theories/setoid_ring/Rings_Z.v new file mode 100644 index 0000000000..8a51bcea02 --- /dev/null +++ b/theories/setoid_ring/Rings_Z.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* * 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/theories/setoid_ring/ZArithRing.v b/theories/setoid_ring/ZArithRing.v new file mode 100644 index 0000000000..833e19a698 --- /dev/null +++ b/theories/setoid_ring/ZArithRing.v @@ -0,0 +1,58 @@ +(************************************************************************) +(* * 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/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v new file mode 100644 index 0000000000..e2ab812cce --- /dev/null +++ b/theories/ssr/ssrbool.v @@ -0,0 +1,2035 @@ +(************************************************************************) +(* * 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). +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). +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). +Reserved Notation "[ && b1 , b2 , .. , bn & c ]" (at level 0, format + "'[hv' [ && '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' & c ] ']'"). + +Reserved Notation "[ || b1 | c ]" (at level 0). +Reserved Notation "[ || b1 , b2 , .. , bn | c ]" (at level 0, format + "'[hv' [ || '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' | c ] ']'"). + +Reserved Notation "[ ==> b1 => c ]" (at level 0). +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/theories/ssr/ssrclasses.v b/theories/ssr/ssrclasses.v new file mode 100644 index 0000000000..0ae3f8c6a5 --- /dev/null +++ b/theories/ssr/ssrclasses.v @@ -0,0 +1,32 @@ +(************************************************************************) +(* * 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/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v new file mode 100644 index 0000000000..701ebcad56 --- /dev/null +++ b/theories/ssr/ssreflect.v @@ -0,0 +1,656 @@ +(************************************************************************) +(* * 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). +Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200). +Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, x ident). + +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/theories/ssr/ssrfun.v b/theories/ssr/ssrfun.v new file mode 100644 index 0000000000..dd847169b9 --- /dev/null +++ b/theories/ssr/ssrfun.v @@ -0,0 +1,812 @@ +(************************************************************************) +(* * 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/theories/ssr/ssrsetoid.v b/theories/ssr/ssrsetoid.v new file mode 100644 index 0000000000..7c5cd135fe --- /dev/null +++ b/theories/ssr/ssrsetoid.v @@ -0,0 +1,38 @@ +(************************************************************************) +(* * 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/theories/ssr/ssrunder.v b/theories/ssr/ssrunder.v new file mode 100644 index 0000000000..7c529a6133 --- /dev/null +++ b/theories/ssr/ssrunder.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* * 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/theories/ssrmatching/ssrmatching.v b/theories/ssrmatching/ssrmatching.v new file mode 100644 index 0000000000..23a16615f5 --- /dev/null +++ b/theories/ssrmatching/ssrmatching.v @@ -0,0 +1,38 @@ +(************************************************************************) +(* * 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 . |