diff options
Diffstat (limited to 'contrib/setoid_ring')
| -rw-r--r-- | contrib/setoid_ring/ArithRing.v | 60 | ||||
| -rw-r--r-- | contrib/setoid_ring/BinList.v | 93 | ||||
| -rw-r--r-- | contrib/setoid_ring/Field.v | 10 | ||||
| -rw-r--r-- | contrib/setoid_ring/Field_tac.v | 406 | ||||
| -rw-r--r-- | contrib/setoid_ring/Field_theory.v | 1944 | ||||
| -rw-r--r-- | contrib/setoid_ring/InitialRing.v | 908 | ||||
| -rw-r--r-- | contrib/setoid_ring/NArithRing.v | 21 | ||||
| -rw-r--r-- | contrib/setoid_ring/RealField.v | 134 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring.v | 44 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring_base.v | 15 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring_equiv.v | 74 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring_polynom.v | 1781 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring_tac.v | 386 | ||||
| -rw-r--r-- | contrib/setoid_ring/Ring_theory.v | 608 | ||||
| -rw-r--r-- | contrib/setoid_ring/ZArithRing.v | 60 | ||||
| -rw-r--r-- | contrib/setoid_ring/newring.ml4 | 1172 |
16 files changed, 0 insertions, 7716 deletions
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v deleted file mode 100644 index 601cabe0..00000000 --- a/contrib/setoid_ring/ArithRing.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -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 Nplus Nmult Neq_bool nat_of_N. -Proof. - constructor;trivial. - exact nat_of_Nplus. - exact nat_of_Nmult. - intros x y H;rewrite (Neq_bool_ok _ _ H);trivial. -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. - -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 - | _ => idtac - end. - -Add Ring natr : natSRth - (morphism nat_morph_N, constants [natcst], preprocess [natprering]). - diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v deleted file mode 100644 index 50902004..00000000 --- a/contrib/setoid_ring/BinList.v +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Set Implicit Arguments. -Require Import BinPos. -Require Export List. -Require Export ListTactics. -Open Local 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 => tail l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tail 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 (tail l)) - end. - - Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. - induction j;simpl;intros. - repeat rewrite IHj;trivial. - repeat rewrite IHj;trivial. - trivial. - Qed. - - Lemma jump_Psucc : forall j l, - (jump (Psucc j) l) = (jump 1 (jump j l)). - Proof. - induction j;simpl;intros. - repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial. - repeat rewrite jump_tl;trivial. - trivial. - Qed. - - Lemma jump_Pplus : forall i j l, - (jump (i + j) l) = (jump i (jump j l)). - Proof. - induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;trivial. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. - Qed. - - Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). - Proof. - induction i;intros;simpl. - repeat rewrite jump_tl;trivial. - rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial. - trivial. - Qed. - - - Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). - Proof. - induction p;simpl;intros. - rewrite <-jump_tl;rewrite IHp;trivial. - rewrite <-jump_tl;rewrite IHp;trivial. - trivial. - Qed. - - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). - Proof. - induction p;simpl;intros. - repeat rewrite jump_tl;trivial. - rewrite jump_Pdouble_minus_one. - repeat rewrite <- jump_tl;rewrite IHp;trivial. - trivial. - Qed. - -End MakeBinList. - - diff --git a/contrib/setoid_ring/Field.v b/contrib/setoid_ring/Field.v deleted file mode 100644 index a944ba5f..00000000 --- a/contrib/setoid_ring/Field.v +++ /dev/null @@ -1,10 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Export Field_theory. -Require Export Field_tac. diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v deleted file mode 100644 index cccee604..00000000 --- a/contrib/setoid_ring/Field_tac.v +++ /dev/null @@ -1,406 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Ring_tac BinList Ring_polynom InitialRing. -Require Export Field_theory. - - (* syntaxification *) - Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := - let rec mkP t := - match Cst t with - | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEadd e1 e2) - | (rmul ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEmul e1 e2) - | (rsub ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEsub e1 e2) - | (ropp ?t1) => - let e1 := mkP t1 in constr:(FEopp e1) - | (rdiv ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEdiv e1 e2) - | (rinv ?t1) => - let e1 := mkP t1 in constr:(FEinv e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - let p := Find_at t fv in constr:(@FEX C p) - | ?c => let e1 := mkP t1 in constr:(FEpow e1 c) - end - - | _ => - let p := Find_at t fv in constr:(@FEX C p) - end - | ?c => constr:(FEc c) - end - in mkP t. - -Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := - let rec TFV t fv := - match Cst t with - | InitialRing.NotConstant => - match t with - | (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. - -Ltac ParseFieldComponents lemma req := - match type of lemma with - | context [ - (* PCond _ _ _ _ _ _ _ _ _ _ _ -> *) - req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv - ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => - (fun f => f radd rmul rsub ropp rdiv rinv rpow C) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - 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 - match goal with - |- ?t => let ft := fold_concl t in change ft - end. - -Ltac simpl_PCond req := - protect_fv "field_cond"; - (try exact I); - fold_field_cond req. - -Ltac simpl_PCond_BEURK req := - protect_fv "field_cond"; - fold_field_cond req. - -(* Rewriting (field_simplify) *) -Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let fv := FV_hypo_tac mkFV req lH in - let simpl_field H := (protect_fv "field" in H;f H) in - let lemma_tac fv RW_tac := - let rr_lemma := fresh "f_rw_lemma" in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t 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); - match type of lemma with - | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] => - compute_assertion vlmp_eq vlmp - (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); - (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq) - || fail 1 "type error when build the rewriting lemma"); - RW_tac rr_lemma; - try clear rr_lemma vlmp_eq vlmp vlpe - | _ => fail 1 "field_simplify anomaly: bad correctness lemma" - end in - ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl; - try (apply Cond_lemma; simpl_PCond req) in - ParseFieldComponents lemma req Main. - -Ltac Field_simplify_gen f := - fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl => - pre(); - Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req - ring_subst_niter lH rl; - post(). - -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 Field_simplify [] rl G. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - field_lookup 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); - generalize H;clear H; - field_lookup 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); - generalize H;clear H; - field_lookup 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 Cst_tac Pow_tac lemma Cond_lemma req n lH := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let rec ParseExpr ilemma := - match type of ilemma with - forall nfe, ?fe = nfe -> _ => - (fun t => - let x := fresh "fld_expr" in - let H := fresh "norm_fld_expr" in - compute_assertion H x fe; - ParseExpr (ilemma x H) t; - try clear x H) - | _ => (fun t => t ilemma) - end 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 := mkHyp_tac C req ltac:(fun t => mkPol t 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"); - ParseExpr nlemma - ltac:(fun ilemma => - apply ilemma - || fail "field anomaly: failed in applying lemma"; - [ Simpl_tac | apply Cond_lemma; simpl_PCond req]); - clear vlpe nlemma in - OnEquation req Main_eq in - ParseFieldComponents lemma req Main. - -(* solve completely a field equation, leaving non-zero conditions to be - proved (field) *) - -Ltac FIELD := - let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in - fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl => - pre(); - Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req - Ring_tac.ring_subst_niter lH; - try exact I; - post(). - -Tactic Notation (at level 0) "field" := - let G := Get_goal in - field_lookup FIELD [] G. - -Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup 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 := - let Simpl := (protect_fv "field") in - fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl => - pre(); - Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok - req Ring_tac.ring_subst_niter lH; - post(). - -Tactic Notation (at level 0) "field_simplify_eq" := - let G := Get_goal in - field_lookup FIELD_SIMPL [] G. - -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup FIELD_SIMPL [lH] G. - -(* Same as FIELD_SIMPL but in hypothesis *) - -Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let hyp := fresh "hyp" in - intro hyp; - match type of hyp with - | req ?t1 ?t2 => - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let rec ParseExpr ilemma := - match type of ilemma with - | forall nfe, ?fe = nfe -> _ => - (fun t => - let x := fresh "fld_expr" in - let H := fresh "norm_fld_expr" in - compute_assertion H x fe; - ParseExpr (ilemma x H) t; - try clear H x) - | _ => (fun t => t ilemma) - end in - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t 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 - ParseExpr (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 | apply Cond_lemma; simpl_PCond_BEURK req] - | protect_fv "field" in tmp; - generalize tmp;clear tmp ]; - clear hyp - end) - end in - ParseFieldComponents lemma req Main. - -Ltac FIELD_SIMPL_EQ := - fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl => - pre(); - Field_simplify_eq cst_tac pow_tac lemma cond_ok req - Ring_tac.ring_subst_niter lH; - post(). - -Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup 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 FIELD_SIMPL_EQ [lH] t; - [ try exact I - |clear H;intro H]. - -(* 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 => - let field_ok3 := constr:(field_ok2 _ ss_spec) in - match d_spec with - | mkhypo ?dd_spec => - let field_ok := constr:(field_ok3 _ 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 coefficiant 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/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v deleted file mode 100644 index b2e5cc4b..00000000 --- a/contrib/setoid_ring/Field_theory.v +++ /dev/null @@ -1,1944 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Ring. -Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List. -Require Import ZArith_base. -(*Require Import Omega.*) -Set Implicit Arguments. - -Section MakeFieldPol. - -(* Field elements *) - 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 / y" := (rdiv x y). - Notation "- x" := (ropp x). Notation "/ x" := (rinv x). - Notation "x == y" := (req x y) (at level 70, no associativity). - - (* Equality properties *) - Variable Rsth : Setoid_Theory R 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 := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). - - (* 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. - -Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type), - (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y). -Proof. -intros. -generalize (fun h => X (morph_eq CRmorph c1 c2 h)). -case (ceqb c1 c2); auto. -Qed. - - - (* C notations *) - Notation "x +! y" := (cadd x y) (at level 50). - Notation "x *! y " := (cmul x y) (at level 40). - Notation "x -! y " := (csub x y) (at level 50). - Notation "-! x" := (copp x) (at level 35). - Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity). - Notation "[ x ]" := (phi x) (at level 0). - - - (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Add Morphism rinv : rinv_ext. 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. - -Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . -Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) - (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. -Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) - (ARmul_1_l ARth) (ARmul_0_l ARth) - (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) - (ARopp_mul_l ARth) (ARopp_add ARth) - (ARsub_def ARth) . - - (* Power coefficients *) - Variable Cpow : Set. - 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. - -Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). -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 : forall r, 0 - r == - r. -intros; rewrite (ARsub_def ARth) in |- *;ring. -Qed. - -Lemma rsub_0_r : forall r, r - 0 == r. -intros; rewrite (ARsub_def ARth) in |- *. -rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. -Qed. - -(*************************************************************************** - - Properties of division - - ***************************************************************************) - -Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. -intros p q H. -rewrite rdiv_def in |- *. -transitivity (/ q * q * p); [ ring | idtac ]. -rewrite rinv_l in |- *; auto. -Qed. -Hint Resolve rdiv_simpl . - -Theorem SRdiv_ext: - forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. -intros p1 p2 H q1 q2 H0. -transitivity (p1 * / q1); auto. -transitivity (p2 * / q2); auto. -Qed. -Hint Resolve SRdiv_ext . - - Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed. - -Lemma rmul_reg_l : forall p q1 q2, - ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. -intros. -rewrite <- (@rdiv_simpl q1 p) in |- *; trivial. -rewrite <- (@rdiv_simpl q2 p) in |- *; trivial. -repeat rewrite rdiv_def in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -auto. -Qed. - -Theorem field_is_integral_domain : forall r1 r2, - ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. -Proof. -red in |- *; intros. -apply H0. -transitivity (1 * r2); auto. -transitivity (/ r1 * r1 * r2); auto. -rewrite <- (ARmul_assoc ARth) in |- *. -rewrite H1 in |- *. -apply ARmul_0_r with (1 := Rsth) (2 := ARth). -Qed. - -Theorem ropp_neq_0 : forall r, - ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. -intros. -setoid_replace (- r) with (- (1) * r). - apply field_is_integral_domain; trivial. - rewrite <- (ARopp_mul_l ARth) in |- *. - rewrite (ARmul_1_l ARth) in |- *. - reflexivity. -Qed. - -Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. -intros. -rewrite (AFdiv_def AFth) in |- *. -rewrite (ARmul_comm ARth) in |- *. -apply (AFinv_l AFth). -trivial. -Qed. - -Theorem rdiv1: forall r, r == r / 1. -intros r; transitivity (1 * (r / 1)); auto. -Qed. - -Theorem rdiv2: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl in |- *; trivial. -rewrite (ARdistr_r Rsth Reqe ARth) in |- *. -apply (Radd_ext Reqe). - transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. - transitivity (r2 * (r4 * (r3 / r4))); auto. - transitivity (r2 * r3); auto. -Qed. - - -Theorem rdiv2b: - forall r1 r2 r3 r4 r5, - ~ (r2*r5) == 0 -> - ~ (r4*r5) == 0 -> - r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)). -Proof. -intros r1 r2 r3 r4 r5 H H0. -assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). -assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). -assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). -assert (HH4: ~ r2 * (r4 * r5) == 0) - by complete (repeat apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * (r4 * r5)); trivial. -rewrite rdiv_simpl in |- *; trivial. -rewrite (ARdistr_r Rsth Reqe ARth) in |- *. -apply (Radd_ext Reqe). - transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ]. - transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ]. -Qed. - -Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2. -intros r1 r2. -transitivity (- (r1 * / r2)); auto. -transitivity (- r1 * / r2); auto. -Qed. -Hint Resolve rdiv5 . - -Theorem rdiv3: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). -transitivity (r1 / r2 + - (r3 / r4)); auto. -transitivity (r1 / r2 + - r3 / r4); auto. -transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto. -apply rdiv2; auto. -apply SRdiv_ext; auto. -transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. -Qed. - - -Theorem rdiv3b: - forall r1 r2 r3 r4 r5, - ~ (r2 * r5) == 0 -> - ~ (r4 * r5) == 0 -> - r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)). -Proof. -intros r1 r2 r3 r4 r5 H H0. -transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto. -transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto. -transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))). -apply rdiv2b; auto; try ring. -apply (SRdiv_ext); auto. -transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. -Qed. - -Theorem rdiv6: - forall r1 r2, - ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1. -intros r1 r2 H H0. -assert (~ r1 / r2 == 0) as Hk. - intros H1; case H. - transitivity (r2 * (r1 / r2)); auto. - rewrite H1 in |- *; ring. - apply rmul_reg_l with (r1 / r2); auto. - transitivity (/ (r1 / r2) * (r1 / r2)); auto. - transitivity 1; auto. - repeat rewrite rdiv_def in |- *. - transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. - repeat rewrite rinv_l in |- *; auto. -Qed. -Hint Resolve rdiv6 . - - Theorem rdiv4: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl in |- *; trivial. -transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. -repeat rewrite rdiv_simpl in |- *; trivial. -Qed. - - Theorem rdiv4b: - forall r1 r2 r3 r4 r5 r6, - ~ r2 * r5 == 0 -> - ~ r4 * r6 == 0 -> - ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 r5 r6 H H0. -rewrite rdiv4; auto. -transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))). -apply SRdiv_ext; ring. -assert (HH: ~ r5*r6 == 0). - apply field_is_integral_domain. - intros H1; case H; rewrite H1; ring. - intros H1; case H0; rewrite H1; ring. -rewrite <- rdiv4 ; auto. - rewrite rdiv_r_r; auto. - - apply field_is_integral_domain. - intros H1; case H; rewrite H1; ring. - intros H1; case H0; rewrite H1; ring. -Qed. - - -Theorem rdiv7: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r3 == 0 -> - ~ r4 == 0 -> - (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). -Proof. -intros. -rewrite (rdiv_def (r1 / r2)) in |- *. -rewrite rdiv6 in |- *; trivial. -apply rdiv4; trivial. -Qed. - -Theorem rdiv7b: - forall r1 r2 r3 r4 r5 r6, - ~ r2 * r6 == 0 -> - ~ r3 * r5 == 0 -> - ~ r4 * r6 == 0 -> - ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3). -Proof. -intros. -rewrite rdiv7; auto. -transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))). -apply SRdiv_ext; ring. -assert (HH: ~ r5*r6 == 0). - apply field_is_integral_domain. - intros H2; case H0; rewrite H2; ring. - intros H2; case H1; rewrite H2; ring. -rewrite <- rdiv4 ; auto. -rewrite rdiv_r_r; auto. - apply field_is_integral_domain. - intros H2; case H; rewrite H2; ring. - intros H2; case H0; rewrite H2; ring. -Qed. - - -Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. -intros r1 r2 H H0. -transitivity (r1 * / r2); auto. -transitivity (0 * / r2); auto. -Qed. - - -Theorem cross_product_eq : forall r1 r2 r3 r4, - ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4. -intros. -transitivity (r1 / r2 * (r4 / r4)). - rewrite rdiv_r_r in |- *; trivial. - symmetry in |- *. - apply (ARmul_1_r Rsth ARth). - rewrite rdiv4 in |- *; trivial. - rewrite H1 in |- *. - rewrite (ARmul_comm ARth r2 r4) in |- *. - rewrite <- rdiv4 in |- *; trivial. - rewrite rdiv_r_r in |- * by trivial. - apply (ARmul_1_r Rsth ARth). -Qed. - -(*************************************************************************** - - Some equality test - - ***************************************************************************) - -Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := - match p1, p2 with - xH, xH => true - | xO p3, xO p4 => positive_eq p3 p4 - | xI p3, xI p4 => positive_eq p3 p4 - | _, _ => false - end. - -Theorem positive_eq_correct: - forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. -intros p1; elim p1; - (try (intros p2; case p2; simpl; auto; intros; discriminate)). -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xI ); auto. -intros H1 H2; case H1; injection H2; auto. -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xO ); auto. -intros H1 H2; case H1; injection H2; auto. -Qed. - -Definition N_eq n1 n2 := - match n1, n2 with - | N0, N0 => true - | Npos p1, Npos p2 => positive_eq p1 p2 - | _, _ => false - end. - -Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2. -Proof. - intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail). - assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2); - [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial]. -Qed. - -(* equality test *) -Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := - match e1, e2 with - PEc c1, PEc c2 => ceqb c1 c2 - | PEX p1, PEX p2 => positive_eq p1 p2 - | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEopp e3, PEopp e4 => PExpr_eq e3 e4 - | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false - | _, _ => false - end. - -Add Morphism (pow_pos rmul) : pow_morph. -intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. -Qed. - -Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph. -intros x y H [|p];simpl;auto. apply pow_morph;trivial. -Qed. -(* -Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n). -Proof. - intros; repeat rewrite pow_th.(rpow_pow_N). - destruct n;simpl. apply eq_refl. - induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl. -Qed. -*) -Theorem PExpr_eq_semi_correct: - forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. -intros l e1; elim e1. -intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). -intros c2; apply (morph_eq CRmorph). -intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). -intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2); - (try (intros; discriminate)); intros H; rewrite H; auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). -intros e4; generalize (rec e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); auto. -intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). -intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4); -intros;try discriminate. -repeat rewrite pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto. -Qed. - -(* add *) -Definition NPEadd e1 e2 := - match e1, e2 with - PEc c1, PEc c2 => PEc (cadd c1 c2) - | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 - | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 - (* Peut t'on factoriser ici ??? *) - | _, _ => PEadd e1 e2 - end. - -Theorem NPEadd_correct: - forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). -Proof. -intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl; - try (ring [(morph0 CRmorph)]). - apply (morph_add CRmorph). -Qed. - -Definition NPEpow x n := - match n with - | N0 => PEc cI - | Npos p => - if positive_eq p xH then x else - match x with - | PEc c => - if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) - | _ => PEpow x n - end - end. - -Theorem NPEpow_correct : forall l e n, - NPEeval l (NPEpow e n) == NPEeval l (PEpow e n). -Proof. - destruct n;simpl. - rewrite pow_th.(rpow_pow_N);simpl;auto. - generalize (positive_eq_correct p xH). - destruct (positive_eq p 1);intros. - rewrite H;rewrite pow_th.(rpow_pow_N). trivial. - clear H;destruct e;simpl;auto. - repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. - symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. - symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. - induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. -Qed. - -(* mul *) -Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := - match x, y with - PEc c1, PEc c2 => PEc (cmul c1 c2) - | PEc c, _ => - if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y - | _, PEc c => - if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y - | PEpow e1 n1, PEpow e2 n2 => - if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y - | _, _ => PEmul x y - end. - -Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. -induction p;simpl;auto;try ring [IHp]. -Qed. - -Theorem NPEmul_correct : forall l e1 e2, - NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). -induction e1;destruct e2; simpl in |- *;try reflexivity; - repeat apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; - try ring [(morph0 CRmorph) (morph1 CRmorph)]. - apply (morph_mul CRmorph). -assert (H:=N_eq_correct n n0);destruct (N_eq n n0). -rewrite NPEpow_correct. simpl. -repeat rewrite pow_th.(rpow_pow_N). -rewrite IHe1;rewrite <- H;destruct n;simpl;try ring. -apply pow_pos_mul. -simpl;auto. -Qed. - -(* sub *) -Definition NPEsub e1 e2 := - match e1, e2 with - PEc c1, PEc c2 => PEc (csub c1 c2) - | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 - | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 - (* Peut-on factoriser ici *) - | _, _ => PEsub e1 e2 - end. - -Theorem NPEsub_correct: - forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2). -intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; - try rewrite (morph0 CRmorph) in |- *; try reflexivity; - try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). -apply (morph_sub CRmorph). -Qed. - -(* opp *) -Definition NPEopp e1 := - match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. - -Theorem NPEopp_correct: - forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). -intros l e1; case e1; simpl; auto. -intros; apply (morph_opp CRmorph). -Qed. - -(* simplification *) -Fixpoint PExpr_simp (e : PExpr C) : PExpr C := - match e with - PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2) - | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) - | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) - | PEopp e1 => NPEopp (PExpr_simp e1) - | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 - | _ => e - end. - -Theorem PExpr_simp_correct: - forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. -intros l e; elim e; simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEadd_correct. -simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEsub_correct. -simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEmul_correct. -simpl; auto. -intros e1 He1. -transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. -apply NPEopp_correct. -simpl; auto. -intros e1 He1 n;simpl. -rewrite NPEpow_correct;simpl. -repeat rewrite pow_th.(rpow_pow_N). -rewrite He1;auto. -Qed. - - -(**************************************************************************** - - Datastructure - - ***************************************************************************) - -(* The input: syntax of a field expression *) - -Inductive FExpr : Type := - 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 - | 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 (NPEeval l e1) rO - | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1 - end. - -Theorem PCond_cons_inv_l : - forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0. -intros l a l1 H. -destruct l1; simpl in H |- *; trivial. -destruct H; trivial. -Qed. - -Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. -intros l a l1 H. -destruct l1; simpl in H |- *; trivial. -destruct H; trivial. -Qed. - -Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1. -intros l l1 l2; elim l1; simpl app in |- *. - simpl in |- *; auto. - destruct l0; simpl in *. - destruct l2; firstorder. - firstorder. -Qed. - -Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. -intros l l1 l2; elim l1; simpl app; auto. -intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). -Qed. - -(* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons (PEc cO) nil. - -Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. -unfold absurd_PCond in |- *; simpl in |- *. -red in |- *; intros. -apply H. -apply (morph0 CRmorph). -Qed. - -(*************************************************************************** - - Normalisation - - ***************************************************************************) - -Fixpoint isIn (e1:PExpr C) (p1:positive) - (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := - match e2 with - | PEmul e3 e4 => - match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) - | Some (Npos p, e5) => - match isIn e1 p e4 p2 with - | Some (n, e6) => Some (n, NPEmul e5 e6) - | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) - end - | None => - match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) - | None => None - end - end - | PEpow e3 N0 => None - | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) - | _ => - if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with - | Zpos p => Some (Npos p, PEc cI) - | Z0 => Some (N0, PEc cI) - | Zneg p => Some (N0, NPEpow e2 (Npos p)) - end - else None - end. - - Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. - Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - - Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) - ARth.(ARmul_comm) ARth.(ARmul_assoc)). - - Lemma isIn_correct_aux : forall l e1 e2 p1 p2, - match - (if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with - | Zpos p => Some (Npos p, PEc cI) - | Z0 => Some (N0, PEc cI) - | Zneg p => Some (N0, NPEpow e2 (Npos p)) - end - else None) - with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == - NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ - (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. - intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); - case (PExpr_eq e1 e2); simpl; auto; intros H. - case_eq ((p1 ?= p2)%positive Eq);intros;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). - rewrite (Pcompare_Eq_eq _ _ H0). - rewrite H by trivial. ring [ (morph1 CRmorph)]. - fold (NPEpow e2 (Npos (p2 - p1))). - rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. split. 2:refine (refl_equal _). - rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. - change (ZtoN - match (p1 ?= p1 - p2)%positive Eq with - | Eq => 0 - | Lt => Zneg (p1 - p2 - p1) - | Gt => Zpos (p1 - (p1 - p2)) - end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))). - replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z. - split. - repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). - rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. - ring [ (morph1 CRmorph)]. - assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). - apply Zplus_gt_reg_l with (Zpos p2). - rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. - apply Zplus_gt_compat_r. refine (refl_equal _). - simpl;rewrite H0;trivial. -Qed. - -Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). -induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl. -ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. -Qed. - - -Theorem isIn_correct: forall l e1 p1 e2 p2, - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == - NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ - (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. -Opaque NPEpow. -intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; - try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. -generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. -destruct n. - simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. - generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5. - destruct n;simpl. - rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite pow_pos_mul. rewrite H1;rewrite H3. - assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == - pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * - NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. - rewrite <- pow_pos_plus. rewrite Pplus_minus. - split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite H2 in H1;simpl in H1. - assert (Zpos p1 > Zpos p6)%Z. - apply Zgt_trans with (Zpos p4). exact H4. exact H2. - unfold Zgt in H;simpl in H;rewrite H. - split. 2:exact H. - rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. - assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == - pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * - NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. - rewrite <- pow_pos_plus. - replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. - rewrite NPEmul_correct. simpl;ring. - assert - (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. - change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). - rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). - simpl. rewrite Pcompare_refl. simpl. reflexivity. - unfold Zminus, Zopp in H0. simpl in H0. - rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. - simpl. repeat rewrite pow_th.(rpow_pow_N). - intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. - rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. - rewrite pow_pos_mul. split. ring [H2]. exact H3. - generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3. - destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1]. - rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. - intros (H1, H2);rewrite H1;split. - unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. - simpl in H1;ring [H1]. trivial. - trivial. - destruct n. trivial. - generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. - destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. - intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial. - repeat rewrite pow_th.(rpow_pow_N). simpl. - intros (H1,H2);split;trivial. - rewrite pow_pos_pow_pos;trivial. - trivial. -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: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit := - match e1 with - | PEmul e3 e4 => - let r1 := split_aux e3 p e2 in - let r2 := split_aux e4 p (right r1) in - mk_rsplit (NPEmul (left r1) (left r2)) - (NPEmul (common r1) (common r2)) - (right r2) - | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 - | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 - | _ => - match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 - | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 - | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 - end - end. - -Lemma split_aux_correct_1 : forall l e1 p e2, - let res := match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 - | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 - | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 - end in - NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) - /\ - NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). -Proof. - intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). - destruct (isIn e1 p e2 1). destruct p0. - Opaque NPEpow NPEmul. - destruct n;simpl; - (repeat rewrite NPEmul_correct;simpl; - repeat rewrite NPEpow_correct;simpl; - repeat rewrite pow_th.(rpow_pow_N);simpl). - intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. - intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H. - simpl in H;split;try ring [H]. - rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. - simpl;intros. repeat rewrite NPEmul_correct;simpl. - rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. -Qed. - -Theorem split_aux_correct: forall l e1 p e2, - NPEeval l (PEpow e1 (Npos p)) == - NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) -/\ - NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) - (common (split_aux e1 p e2))). -Proof. -intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. -generalize (IHe1_1 k e2); clear IHe1_1. -generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. -simpl. repeat (rewrite NPEmul_correct;simpl). -repeat rewrite pow_th.(rpow_pow_N);simpl. -intros (H1,H2) (H3,H4);split. -rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. -rewrite H4;rewrite H2;ring. -destruct n;simpl. -split. repeat rewrite pow_th.(rpow_pow_N);simpl. -rewrite NPEmul_correct. simpl. - induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)]. - rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)]. -generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl. -repeat rewrite NPEmul_correct;simpl. -repeat rewrite pow_th.(rpow_pow_N);simpl. -rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. -Qed. - -Definition split e1 e2 := split_aux e1 xH e2. - -Theorem split_correct_l: forall l e1 e2, - NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) - (common (split e1 e2))). -Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. -rewrite pow_th.(rpow_pow_N);simpl;auto. -Qed. - -Theorem split_correct_r: forall l e1 e2, - NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) - (common (split e1 e2))). -Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. -Qed. - -Fixpoint Fnorm (e : FExpr) : linear := - match e with - | FEc c => mk_linear (PEc c) (PEc cI) nil - | FEX x => mk_linear (PEX C x) (PEc cI) nil - | FEadd e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) - (NPEmul (left s) (NPEmul (right s) (common s))) - (condition x ++ condition y) - - | FEsub e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) - (NPEmul (left s) (NPEmul (right s) (common s))) - (condition x ++ condition y) - | 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 (NPEmul (left s1) (left s2)) - (NPEmul (right s2) (right s1)) - (condition x ++ condition y) - | 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 (NPEmul (left s1) (right s2)) - (NPEmul (left s2) (right s1)) - (num y :: condition x ++ condition y) - | FEpow e1 n => - let x := Fnorm e1 in - mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) - end. - - -(* Example *) -(* -Eval compute - in (Fnorm - (FEdiv - (FEc cI) - (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). -*) - - Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0. -Proof. - induction p;simpl. - intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). - apply IHp. - rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). - reflexivity. - rewrite H1. ring. rewrite Hp;ring. - intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). - reflexivity. rewrite Hp;ring. trivial. -Qed. - -Theorem Pcond_Fnorm: - forall l e, - PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. -intros l e; elim e. - simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. - simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; case Hrec1; auto. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; case Hrec2; auto. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; case Hrec1; auto. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; case Hrec2; auto. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; apply Hrec1. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; apply Hrec2. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros e1 Hrec1 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - auto. - intros e1 Hrec1 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - apply PCond_cons_inv_l with (1:=Hcond). - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; apply Hrec1. - specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. - apply PCond_app_inv_l with (1 := Hcond1). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; apply PCond_cons_inv_l with (1:=Hcond). - rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - simpl;intros e1 Hrec1 n Hcond. - rewrite NPEpow_correct. - simpl;rewrite pow_th.(rpow_pow_N). - destruct n;simpl;intros. - apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. -Qed. -Hint Resolve Pcond_Fnorm. - - -(*************************************************************************** - - Main theorem - - ***************************************************************************) - -Theorem Fnorm_FEeval_PEeval: - forall l fe, - PCond l (condition (Fnorm fe)) -> - FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)). -Proof. -intros l fe; elim fe; simpl. -intros c H; rewrite CRmorph.(morph1); apply rdiv1. -intros p H; rewrite CRmorph.(morph1); apply rdiv1. -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -rewrite NPEadd_correct; simpl. -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2; rewrite U1; rewrite U2. -apply rdiv2b; auto. - rewrite <- U1; auto. - rewrite <- U2; auto. - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -rewrite NPEsub_correct; simpl. -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2; rewrite U1; rewrite U2. -apply rdiv3b; auto. - rewrite <- U1; auto. - rewrite <- U2; auto. - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1))) - (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; - rewrite U4; simpl. -apply rdiv4b; auto. - rewrite <- U4; auto. - rewrite <- U2; auto. - -intros e1 He1 HH. -rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. - -intros e1 He1 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_cons_inv_r with ( 1 := HH ). -rewrite (He1 HH1); apply rdiv6; auto. -apply PCond_cons_inv_l with ( 1 := HH ). - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with (condition (Fnorm e2)). -apply PCond_cons_inv_r with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with (condition (Fnorm e1)). -apply PCond_cons_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -repeat rewrite NPEmul_correct;simpl. -generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2))) - (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))) - (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; - rewrite U4; simpl. -apply rdiv7b; auto. - rewrite <- U3; auto. - rewrite <- U2; auto. -apply PCond_cons_inv_l with ( 1 := HH ). - rewrite <- U4; auto. - -intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. -repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). -rewrite He1';clear He1'. -destruct n;simpl. apply rdiv1. -generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1))) - (Pcond_Fnorm _ _ Hcond). -intros r r0 Hdiff;induction p;simpl. -repeat (rewrite <- rdiv4;trivial). -rewrite IHp. reflexivity. -apply pow_pos_not_0;trivial. -apply pow_pos_not_0;trivial. -intro Hp. apply (pow_pos_not_0 Hdiff p). -rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). - reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. -rewrite <- rdiv4;trivial. -rewrite IHp;reflexivity. -apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. -reflexivity. -Qed. - -Theorem Fnorm_crossproduct: - forall l fe1 fe2, - let nfe1 := Fnorm fe1 in - let nfe2 := Fnorm fe2 in - NPEeval l (PEmul (num nfe1) (denum nfe2)) == - NPEeval l (PEmul (num nfe2) (denum nfe1)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. -rewrite Fnorm_FEeval_PEeval in |- * by - apply PCond_app_inv_l with (1 := Hcond). - rewrite Fnorm_FEeval_PEeval in |- * by - apply PCond_app_inv_r with (1 := Hcond). - apply cross_product_eq; trivial. - apply Pcond_Fnorm. - apply PCond_app_inv_l with (1 := Hcond). - apply Pcond_Fnorm. - apply PCond_app_inv_r with (1 := Hcond). -Qed. - -(* Correctness lemmas of reflexive tactics *) -Notation Ninterp_PElist := (interp_PElist rO 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_correct: - 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. -intros n l lpe fe Hlpe H H1; - apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). -apply rdiv8; auto. -transitivity (NPEeval l (PEc cO)); auto. -rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto. -change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)). -apply (Peq_ok Rsth Reqe CRmorph);auto. -simpl. apply (morph0 CRmorph); auto. -Qed. - -(* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) -Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. - -Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. - -Theorem Field_rw_correct : - forall 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 n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply SRdiv_ext; - eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto. -Qed. - -Theorem Field_rw_pow_correct : - forall 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 n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply SRdiv_ext; - eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto. -Qed. - -Theorem Field_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 -> - Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2))) - (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. -apply Fnorm_crossproduct; trivial. -eapply (ring_correct Rsth Reqe ARth CRmorph); eauto. -Qed. - -(* simplify a field equation : generate the crossproduct and simplify - polynomials *) -Theorem Field_simplify_eq_old_correct : - forall l fe1 fe2 nfe1 nfe2, - Fnorm fe1 = nfe1 -> - Fnorm fe2 = nfe2 -> - NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) == - NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. -apply Fnorm_crossproduct; trivial. -match goal with - [ |- NPEeval l ?x == NPEeval l ?y] => - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) - end. -trivial. -Qed. - -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 (PEmul (num nfe1) (right den))) == - NPphi_dev l (Nnorm n lmp (PEmul (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; - subst nfe1 nfe2 den lmp. -apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -rewrite <-( - let x := PEmul (num (Fnorm fe1)) - (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -rewrite <-( - let x := (PEmul (num (Fnorm fe2)) - (rsplit_left - (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod in |- *. -reflexivity. -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 (PEmul (num nfe1) (right den))) == - NPphi_pow l (Nnorm n lmp (PEmul (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; - subst nfe1 nfe2 den lmp. -apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -rewrite <-( - let x := PEmul (num (Fnorm fe1)) - (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -rewrite <-( - let x := (PEmul (num (Fnorm fe2)) - (rsplit_left - (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod in |- *. -reflexivity. -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 (PEmul (num nfe1) (right den)) = np1 -> - forall np2, Nnorm n lmp (PEmul (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. - repeat 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. - assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). - assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). - intro Heq;apply N1. - rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). - rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. - repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). - repeat rewrite <- ARth.(ARmul_assoc). - change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). - change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). - repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l. - rewrite <- split_correct_r. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. - ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. - ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. - rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (AFth.(AFdiv_def)). - repeat rewrite <- Fnorm_FEeval_PEeval ; trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). -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 (PEmul (num nfe1) (right den)) = np1 -> - forall np2, Nnorm n lmp (PEmul (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. - repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. - assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). - assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). - intro Heq;apply N1. - rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). - rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. - repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). - repeat rewrite <- ARth.(ARmul_assoc). - change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). - change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). - repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l. - rewrite <- split_correct_r. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. - ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. - ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. - rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (AFth.(AFdiv_def)). - repeat rewrite <- Fnorm_FEeval_PEeval;trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). -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) -> ~ NPEeval l a == 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_correct : forall l l1, - PCond l (Fapp l1 nil) -> PCond l l1. -induction l1; simpl in |- *; intros. - trivial. - elim PCond_fcons_inv with (1 := H); intros. - destruct l1; auto. -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) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a l1; elim l1; simpl Fcons; auto. -simpl; auto. -intros a0 l0. -generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0). -intros H H0 H1; split; auto. -rewrite H; auto. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -intros H H0 H1; - assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). -split. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -apply H0. -generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -generalize Hp; case l0; simpl; intuition. -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) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a l1; elim l1; simpl Fcons0; auto. -simpl; auto. -intros a0 l0. -generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl. - case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)). -intros H H0 H1; split; auto. -rewrite H; auto. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -intros H H0 H1; - assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). -split. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -apply H0. -generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -clear get_sign get_sign_spec. -generalize Hp; case l0; simpl; intuition. -Qed. - -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) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). - intros p H p0 H0 l1 H1. - simpl in H1. - case (H _ H1); intros H2 H3. - case (H0 _ H3); intros H4 H5; split; auto. - simpl in |- *. - apply field_is_integral_domain; trivial. - simpl;intros. rewrite pow_th.(rpow_pow_N). - destruct (H _ H0);split;auto. - destruct n;simpl. apply AFth.(AF_1_neq_0). - apply pow_pos_not_0;trivial. -Qed. - -Definition Pcond_simpl_gen := - fcons_correct _ 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, phi c1 == phi c2 -> ceqb c1 c2 = true. - -Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type), - (phi c1 == phi c2 -> P x) -> - (~ phi c1 == phi c2 -> P y) -> - P (if ceqb c1 c2 then x else y). -Proof. -intros. -generalize (fun h => X (morph_eq CRmorph c1 c2 h)). -generalize (@ceqb_complete c1 c2). -case (c1 ?=! c2); auto; intros. -apply X0. -red in |- *; intro. -absurd (false = true); auto; 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 ceqb (copp cI) cO then absurd_PCond else Fcons1 e l - | PEc c => if ceqb c cO then absurd_PCond else l - | _ => Fcons0 e l - end. - -Theorem PFcons1_fcons_inv: - forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). - simpl in |- *; intros c l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H0). - split; trivial. - rewrite <- (morph0 CRmorph) in |- *; trivial. - intros p H p0 H0 l1 H1. - simpl in H1. - case (H _ H1); intros H2 H3. - case (H0 _ H3); intros H4 H5; split; auto. - simpl in |- *. - apply field_is_integral_domain; trivial. - simpl in |- *; intros p H l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H1). - destruct (H _ H1). - split; trivial. - apply ropp_neq_0; trivial. - rewrite (morph_opp CRmorph) in H0. - rewrite (morph1 CRmorph) in H0. - rewrite (morph0 CRmorph) in H0. - trivial. - intros;simpl. destruct (H _ H0);split;trivial. - rewrite pow_th.(rpow_pow_N). destruct n;simpl. - apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. -Qed. - -Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. - -Theorem PFcons2_fcons_inv: - forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -unfold Fcons2 in |- *; intros l a l1 H; split; - case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. -intros H1 H2 H3; case H1. -transitivity (NPEeval l a); trivial. -apply PExpr_simp_correct. -Qed. - -Definition Pcond_simpl_complete := - fcons_correct _ 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.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). - - 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.(SF_SR)) - sf.(SF_1_neq_0) - sf.(SFdiv_def) - sf.(SFinv_l). - - -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 Setoid R req Rsth as R_setoid3. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. - -Section AlmostField. - - Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). - -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 : forall p x y, - gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. -intros p x y. -elim p using Pind; simpl in |- *; intros. - apply S_inj; trivial. - apply H. - apply S_inj. - repeat rewrite (ARadd_assoc ARth) in |- *. - rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial. -Qed. - -Lemma gen_phiPOS_inj : forall x y, - gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> - x = y. -intros x y. -repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *. -ElimPcompare x y; intro. - intros. - apply Pcompare_Eq_eq; trivial. - intro. - elim gen_phiPOS_not_0 with (y - x)%positive. - apply add_inj_r with x. - symmetry in |- *. - rewrite (ARadd_0_r Rsth ARth) in |- *. - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. - rewrite Pplus_minus in |- *; trivial. - change Eq with (CompOpp Eq) in |- *. - rewrite <- Pcompare_antisym in |- *; trivial. - rewrite H in |- *; trivial. - intro. - elim gen_phiPOS_not_0 with (x - y)%positive. - apply add_inj_r with y. - rewrite (ARadd_0_r Rsth ARth) in |- *. - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. - rewrite Pplus_minus in |- *; trivial. -Qed. - - -Lemma gen_phiN_inj : forall x y, - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - x = y. -destruct x; destruct y; simpl in |- *; intros; trivial. - elim gen_phiPOS_not_0 with p. - symmetry in |- *. - rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. - rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial. -Qed. - -Lemma gen_phiN_complete : forall x y, - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - Neq_bool x y = true. -intros. - replace y with x. - unfold Neq_bool in |- *. - rewrite Ncompare_refl in |- *; trivial. - apply gen_phiN_inj; trivial. -Qed. - -End AlmostField. - -Section Field. - - Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := Fth.(F_R). - Let rI_neq_rO := Fth.(F_1_neq_0). - Let rdiv_def := Fth.(Fdiv_def). - Let rinv_l := Fth.(Finv_l). - Let AFth := F2AF Rsth Reqe Fth. - Let ARth := Rth_ARth Rsth Reqe Rth. - -Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y. -intros. -transitivity (x + (1 + - (1))). - rewrite (Ropp_def Rth) in |- *. - symmetry in |- *. - apply (ARadd_0_r Rsth ARth). - transitivity (y + (1 + - (1))). - repeat rewrite <- (ARplus_assoc ARth) in |- *. - repeat rewrite (ARadd_assoc ARth) in |- *. - apply (Radd_ext Reqe). - repeat rewrite <- (ARadd_comm ARth 1) in |- *. - trivial. - reflexivity. - rewrite (Ropp_def Rth) in |- *. - apply (ARadd_0_r Rsth ARth). -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 : forall x y, - ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. -red in |- *; intros. -apply gen_phiPOS_not_0 with (y + x)%positive. -rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. -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) in |- *. - rewrite (same_gen Rsth Reqe ARth) in |- *. - trivial. - apply (Ropp_def Rth). -Qed. - -Lemma gen_phiZ_inj : forall x y, - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - x = y. -destruct x; destruct y; simpl in |- *; intros. - trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - symmetry in |- *; trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite <- H in |- *. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - trivial. - rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial. - elim gen_phiPOS_discr_sgn with (1 := H). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite H in |- *. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_discr_sgn with p0 p. - symmetry in |- *; trivial. - replace p0 with p; trivial. - apply gen_phiPOS_inject. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *. - rewrite H in |- *; trivial. - reflexivity. -Qed. - -Lemma gen_phiZ_complete : forall x y, - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - Zeq_bool x y = true. -intros. - replace y with x. - unfold Zeq_bool in |- *. - rewrite Zcompare_refl in |- *; trivial. - apply gen_phiZ_inj; trivial. -Qed. - -End Field. - -End Complete. diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v deleted file mode 100644 index e664b3b7..00000000 --- a/contrib/setoid_ring/InitialRing.v +++ /dev/null @@ -1,908 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import ZArith_base. -Require Import Zpow_def. -Require Import BinInt. -Require Import BinNat. -Require Import Setoid. -Require Import Ring_theory. -Require Import Ring_polynom. -Require Import ZOdiv_def. -Import List. - -Set Implicit Arguments. - -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 Zplus Zmult Zopp (@eq Z). -Proof (Eq_ext Zplus Zmult Zopp). - -Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z). -Proof. - constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc. - exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc. - exact Zmult_plus_distr_l. trivial. exact Zminus_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 Setoid R req Rsth as R_setoid3. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. 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 Zopp Zeq_bool get_signZ. - Proof. - constructor. - destruct c;intros;try discriminate. - injection H;clear H;intros H1;subst c'. - simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. - Qed. - - - Section ALMOST_RING. - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext3. 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 (Psucc 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 Pplus_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 : rsub_ext4. 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 extensionaly 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_add_pos_neg : forall x y, - gen_phiZ1 - match (x ?= y)%positive Eq with - | Eq => Z0 - | Lt => Zneg (y - x) - | Gt => Zpos (x - y) - end - == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y). - generalize (Pminus_mask_Gt y x). - replace Eq with (CompOpp Eq);[intro H1;simpl|trivial]. - rewrite <- Pcompare_antisym in H1. - destruct ((x ?= y)%positive Eq). - rewrite H;trivial. rewrite (Ropp_def Rth);rrefl. - destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - rewrite (Ropp_def Rth);norm. - destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); 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 ARth). - apply gen_phiZ1_add_pos_neg. - replace Eq with (CompOpp Eq);trivial. - rewrite <- Pcompare_antisym;simpl. - rewrite match_compOpp. - rewrite (Radd_comm Rth). - apply gen_phiZ1_add_pos_neg. - 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) - Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) - Zplus Zmult 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 Nplus Nmult (@eq N). -Proof (Eq_s_ext Nplus Nmult). - -Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). -Proof. - constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. - exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. - exact Nmult_plus_distr_r. -Qed. - -Definition Nsub := SRsub Nplus. -Definition Nopp := (@SRopp N). - -Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). -Proof (SReqe_Reqe Nseqe). - -Lemma Nath : - almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). -Proof (SRth_ARth Nsth Nth). - -Definition Neq_bool (x y:N) := - match Ncompare x y with - | Eq => true - | _ => false - end. - -Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. - -Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. - -(**Same as above : definition of two,extensionaly 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 Setoid R req 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 : radd_ext4. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext4. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext5. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 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. rrefl. - rewrite (same_gen Rsth Reqe ARth);rrefl. - 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 - N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN. - Proof. - constructor;intros;simpl; try rrefl. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - rewrite (Neq_bool_ok x y);trivial. rrefl. - 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 Neq_bool 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 Setoid R req Rsth as R_setoid5. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext7. 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 in |- *; intros; auto. - reflexivity. - - destruct a. - destruct w. - reflexivity. - - rewrite IHw in |- *; 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 in |- *; 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 in |- *. - rewrite gen_phiNword_cons in |- *. - reflexivity. -Qed. - - Lemma gen_phiNword_ok : forall w1 w2, - Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. -induction w1; intros. - simpl in |- *. - rewrite (gen_phiNword0_ok _ H) in |- *. - reflexivity. - - rewrite gen_phiNword_cons in |- *. - destruct w2. - simpl in H. - destruct a; try discriminate. - rewrite (gen_phiNword0_ok _ H) in |- *. - norm. - - simpl in H. - rewrite gen_phiNword_cons in |- *. - case_eq (Neq_bool a n); intros. - rewrite H0 in H. - rewrite <- (Neq_bool_ok _ _ H0) in |- *. - rewrite (IHw1 _ H) in |- *. - 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 in |- *. - norm. - - destruct y. - simpl Nwadd; norm. - - simpl Nwadd in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by - (destruct Reqe; constructor; trivial). - - rewrite IHx in |- *. - norm. - add_push (- gen_phiNword x); reflexivity. -Qed. - -Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. -simpl in |- *. -unfold Nwopp in |- *; simpl in |- *. -intros. -rewrite gen_phiNword_Nwcons in |- *; 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 in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- * - by (destruct Reqe; constructor; trivial). - - rewrite IHx in |- *. - 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 in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. - norm. - - simpl Nwmul in |- *. - unfold Nwsub in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwscal_ok in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. - 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 in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwopp_ok in |- *. - 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 Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. 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.(morph_eq) 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 Zplus Zmult zphi ZOdiv_eucl. - Proof. - constructor. - intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst. - rewrite Zmult_comm; rsimpl. - Qed. - - Variable nphi : N -> R. - - Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl. - constructor. - intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst. - rewrite Nmult_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 reifid 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 Zplus Zmult ?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 Nplus Nmult ?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 => - match 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 - match 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 - match d_spec with - | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => - let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in - match 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 4 "ring: bad sign specification" - end - | _ => fail 3 "ring: bad coefficiant division specification" - end - | _ => fail 2 "ring: bad power specification" - end - | _ => fail 1 "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 *) - | P_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/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v deleted file mode 100644 index 0ba519fd..00000000 --- a/contrib/setoid_ring/NArithRing.v +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -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 Neq_bool_ok, constants [Ncst]). diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v deleted file mode 100644 index 60641bcf..00000000 --- a/contrib/setoid_ring/RealField.v +++ /dev/null @@ -1,134 +0,0 @@ -Require Import Nnat. -Require Import ArithRing. -Require Export Ring Field. -Require Import Rdefinitions. -Require Import Rpow_def. -Require Import Raxioms. - -Open Local 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 in |- *; apply Rplus_assoc. - intro; apply Rmult_1_l. - exact Rmult_comm. - symmetry in |- *; apply Rmult_assoc. - intros m n p. - rewrite Rmult_comm in |- *. - rewrite (Rmult_comm n p) in |- *. - rewrite (Rmult_comm m p) in |- *. - 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 in |- *. - rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. - rewrite <- Rplus_assoc in |- *. - rewrite Rplus_opp_r in |- *. - apply Rplus_0_l. - elim H0. - unfold Rminus in |- *. - rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. - rewrite <- Rplus_assoc in |- *. - rewrite Rplus_opp_r in |- *. - rewrite Rplus_0_l in |- *; trivial. -Qed. - -Notation Rset := (Eqsth R). -Notation Rext := (Eq_ext Rplus Rmult Ropp). - -Lemma Rlt_0_2 : 0 < 2. -apply Rlt_trans with (0 + 1). - apply Rlt_n_Sn. - rewrite Rplus_comm in |- *. - apply Rplus_lt_compat_l. - replace 1 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 in |- *. -induction x; simpl in |- *; intros. - apply Rlt_trans with (1 + 0). - rewrite Rplus_comm in |- *. - apply Rlt_n_Sn. - apply Rplus_lt_compat_l. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. - apply Rmult_lt_compat_l. - apply Rlt_0_2. - trivial. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. - 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 in |- *; intros. -specialize (Rgen_phiPOS x). -rewrite H in |- *; 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 in |- *; auto with real. - intros n0 H' m; rewrite H'; auto with real. -Qed. - -Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. -Proof. - constructor. destruct n. reflexivity. - simpl. induction p;simpl. - rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. - unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. - 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. - -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - - diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v deleted file mode 100644 index d01b1625..00000000 --- a/contrib/setoid_ring/Ring.v +++ /dev/null @@ -1,44 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -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 in |- *. -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/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v deleted file mode 100644 index 956a15fe..00000000 --- a/contrib/setoid_ring/Ring_base.v +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* This module gathers the necessary base to build an instance of the - ring tactic. Abstract rings need more theory, depending on - ZArith_base. *) - -Require Export Ring_theory. -Require Export Ring_tac. -Require Import InitialRing. diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v deleted file mode 100644 index 945f6c68..00000000 --- a/contrib/setoid_ring/Ring_equiv.v +++ /dev/null @@ -1,74 +0,0 @@ -Require Import Setoid_ring_theory. -Require Import LegacyRing_theory. -Require Import Ring_theory. - -Set Implicit Arguments. - -Section Old2New. - -Variable A : Type. - -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. -Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. - -Let Aminus := fun x y => Aplus x (Aopp y). - -Lemma ring_equiv1 : - ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)). -Proof. -destruct R. -split; eauto. -Qed. - -End Old2New. - -Section New2OldRing. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)). - - Variable reqb : R -> R -> bool. - Variable reqb_ok : forall x y, reqb x y = true -> x = y. - - Lemma ring_equiv2 : - Ring_Theory radd rmul rI rO ropp reqb. -Proof. -elim Rth; intros; constructor; eauto. -intros. -apply reqb_ok. -destruct (reqb x y); trivial; intros. -elim H. -Qed. - - Definition default_eqb : R -> R -> bool := fun x y => false. - Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y. -Proof. -discriminate 1. -Qed. - -End New2OldRing. - -Section New2OldSemiRing. - Variable R : Type. - Variable (rO rI : R) (radd rmul: R->R->R). - Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)). - - Variable reqb : R -> R -> bool. - Variable reqb_ok : forall x y, reqb x y = true -> x = y. - - Lemma sring_equiv2 : - Semi_Ring_Theory radd rmul rI rO reqb. -Proof. -elim SRth; intros; constructor; eauto. -intros. -apply reqb_ok. -destruct (reqb x y); trivial; intros. -elim H. -Qed. - -End New2OldSemiRing. diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v deleted file mode 100644 index d8847036..00000000 --- a/contrib/setoid_ring/Ring_polynom.v +++ /dev/null @@ -1,1781 +0,0 @@ -(************************************************************************) -(* V * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Export Ring_theory. - -Open Local Scope positive_scope. -Import RingSyntax. - -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 : 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. - - (* 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 : Set. - 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. - 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). - - (* C notations *) - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. 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. - - (* 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 Pcompare j j' Eq with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match Pcompare i i' Eq with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Notation " P ?== P' " := (Peq P P'). - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj ((j + j'):positive) Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P:= - match j with - | xH => P - | xO j => Pinj (Pdouble_minus_one 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) {struct P} : 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) {struct P} : 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){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match ZPminus 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 (Pdouble_minus_one j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match ZPminus 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 (Pdouble_minus_one j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) {struct P} : 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 (Pdouble_minus_one j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus 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) {struct P} : 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 (Pdouble_minus_one j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus 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 (Pdouble_minus_one j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus 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. - Notation "P ++ P'" := (Padd P P'). - - 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 (Pdouble_minus_one j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus 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. - Notation "P -- P'" := (Psub P P'). - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : 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) {struct P} : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match ZPminus 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 (Pdouble_minus_one j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. -(* A symmetric version of the multiplication *) - - 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 (Pdouble_minus_one 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. - -(* Non symmetric *) -(* - Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := - match P' with - | Pc c' => PmulC P c' - | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => - (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) - end. - - Definition Pmul P P' := - match P with - | Pc c => PmulC P' c - | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => - (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') - end. -*) - Notation "P ** P'" := (Pmul P P'). - - 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 **) - - Inductive Mon: Set := - mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := - match M with - mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi - end. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Ppred 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 -(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *) - CFactor P c - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) Eq 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) Eq 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) {struct n}: 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) {struct LM1}: - 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) {struct LM1}: 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) {struct m}: 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:list R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - (** Proofs *) - Lemma ZPminus_spec : forall x y, - match ZPminus x y with - | Z0 => x = y - | Zpos k => x = (y + k)%positive - | Zneg k => y = (x + k)%positive - end. - Proof. - induction x;destruct y. - replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - simpl;trivial. - replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. - replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - simpl;trivial. - Qed. - - Lemma Peq_ok : forall P P', - (P ?== P') = true -> forall l, P@l == P'@ l. - Proof. - induction P;destruct P';simpl;intros;try discriminate;trivial. - apply (morph_eq CRmorph);trivial. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite H1;trivial. clear H1. - assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); - destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] - |discriminate H]. - rewrite (H1 H);rewrite (H2 H);rrefl. - Qed. - - Lemma Pphi0 : forall l, P0@l == 0. - Proof. - intros;simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 : forall l, P1@l == 1. - Proof. - intros;simpl;apply (morph1 CRmorph). - Qed. - - Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). - Proof. - intros j l p;destruct p;simpl;rsimpl. - rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. - Qed. - - Let pow_pos_Pplus := - pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). - - Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). - Proof. - intros l P i Q;unfold mkPX. - destruct P;try (simpl;rrefl). - assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. - rewrite (H (refl_equal true));rewrite (morph0 CRmorph). - rewrite mkPinj_ok;rsimpl;simpl;rrefl. - assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. - rewrite (H (refl_equal true));trivial. - rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. - Qed. - - Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [?P@?l] => - match P with - | P0 => rewrite (Pphi0 l) - | P1 => rewrite (Pphi1 l) - | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P) - | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q) - end - | |- context [[?c]] => - match c with - | cO => rewrite (morph0 CRmorph) - | cI => rewrite (morph1 CRmorph) - | ?x +! ?y => rewrite ((morph_add CRmorph) x y) - | ?x *! ?y => rewrite ((morph_mul CRmorph) x y) - | ?x -! ?y => rewrite ((morph_sub CRmorph) x y) - | -! ?x => rewrite ((morph_opp CRmorph) x) - end - end)); - rsimpl; simpl. - - Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. - Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1;rewrite IHP2;rsimpl. - mul_push ([c]);rrefl. - Qed. - - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. - Proof. - intros c P l; unfold PmulC. - assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). - rewrite (H (refl_equal true));Esimpl. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok : forall P l, (--P)@l == - P@l. - Proof. - induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1;rewrite IHP2;rsimpl. - Qed. - - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) - | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_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 Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. - Proof. - induction P';simpl;intros;Esimpl2. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rrefl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - Esimpl2;add_push [c];rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl. - rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_comm ARth). - destruct p2;simpl;try apply (ARadd_comm ARth). - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. - rewrite IHP'1;simpl;Esimpl. - rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - Qed. - - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. - Proof. - induction P';simpl;intros;Esimpl2;trivial. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. - add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. - rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. - destruct p2;simpl;rewrite Popp_ok;rsimpl. - apply (ARadd_comm ARth);trivial. - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial. - apply (ARadd_comm ARth);trivial. - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. - rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - Qed. -(* Proof for the symmetriv version *) - - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - -(* - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - - Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. - Proof. - induction P';simpl;intros. - Esimpl2;trivial. - apply PmulI_ok;trivial. - rewrite Padd_ok;Esimpl2. - rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. - Qed. -*) - -(* Proof for the symmetric version *) - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - intros P P';generalize P;clear P;induction P';simpl;intros. - apply PmulC_ok. apply PmulI_ok;trivial. - destruct P. - rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. - Esimpl2. rewrite IHP'1;Esimpl2. - assert (match p0 with - | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 - | 1 => P ** P'2 - end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). - destruct p0;simpl;rewrite IHP'2;Esimpl. - rewrite jump_Pdouble_minus_one;Esimpl. - rewrite H;Esimpl. - rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. - repeat (rewrite IHP'1 || rewrite IHP'2);simpl. - rewrite PmulI_ok;trivial. - mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl. - Qed. - -(* -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - destruct P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_comm ARth). - rewrite Padd_ok; Esimpl2. - rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. - rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_comm ARth (P' @ l));rrefl. - Qed. -*) - - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. - Proof. - induction P;simpl;intros;Esimpl2. - apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. - rewrite IHP1;rewrite IHP2. - mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). - rrefl. - Qed. - - - Lemma mkZmon_ok: forall M j l, - Mphi l (mkZmon j M) == Mphi l (zmon j M). - intros M j l; case M; simpl; intros; rsimpl. - Qed. - - Lemma zmon_pred_ok : forall M j l, - Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). - Proof. - destruct j; simpl;intros auto; rsimpl. - rewrite mkZmon_ok;rsimpl. - rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl. - Qed. - - Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. - Proof. - destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. - Qed. - - Lemma Mcphi_ok: forall P c l, - let (Q,R) := CFactor P c in - P@l == Q@l + (phi c) * (R@l). - Proof. - intros P; elim P; simpl; auto; clear P. - intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv. - intros q r H; rewrite H. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros i P Hrec c l. - generalize (Hrec c (jump i l)); case CFactor. - intros R1 S1; Esimpl; auto. - intros Q1 Qrec i R1 Rrec c l. - generalize (Qrec c l); case CFactor; intros S1 S2 HS. - generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1. - rewrite HS; rewrite HS1; Esimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - Qed. - - Lemma Mphi_ok: forall P (cM: C * Mon) l, - let (c,M) := cM in - let (Q,R) := MFactor P c M in - P@l == Q@l + (phi c) * (Mphi l M) * (R@l). - Proof. - intros P; elim P; simpl; auto; clear P. - intros c (c1, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - try rewrite (morph0 CRmorph); rsimpl. - generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1). - intros q r H; rewrite H; clear H H1. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros p m; Esimpl. - intros p m; Esimpl. - intros i P Hrec (c,M) l; case M; simpl; clear M. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P c (jump i l)); case CFactor. - intros R1 Q1 HH; rewrite HH; Esimpl. - intros j M. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); - simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); - case (MFactor P c (zmon (j -i) M)); simpl. - intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). - rewrite Pplus_comm; rewrite jump_Pplus; auto. - rewrite (morph0 CRmorph); rsimpl. - intros P2 m; rewrite (morph0 CRmorph); rsimpl. - - intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P2 c l); case CFactor. - intros S1 S2 HS. - generalize (Mcphi_ok Q2 c (tail l)); case CFactor. - intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1. - rsimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros j M1. - generalize (Hrec1 (c,zmon j M1) l); - case (MFactor P2 c (zmon j M1)). - intros R1 S1 H1. - generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); - case (MFactor Q2 c (zmon_pred j M1)); simpl. - intros R2 S2 H2; rewrite H1; rewrite H2. - repeat rewrite mkPX_ok; simpl. - rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - rewrite zmon_pred_ok;rsimpl. - intros j M1. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite mkZmon_ok. - apply rmul_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (c, vmon (j - i) M1) l); - case (MFactor P2 c (vmon (j - i) M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (c, mkZmon 1 M1) l); - case (MFactor P2 c (mkZmon 1 M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite mkZmon_ok. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - rewrite mkPX_ok; simpl; rsimpl. - rewrite (morph0 CRmorph); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite (ARmul_comm ARth (Q3@l)); rsimpl. - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - repeat (rewrite <- (ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ He); rsimpl. - Qed. - -(* Proof for the symmetric version *) - - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l. - Proof. - intros P2 (cc,M1) P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - (* new version *) - rewrite Padd_ok; rewrite PmulC_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - assert (P4 = Q1 ++ P3 ** PX i P5 P6). - injection H2; intros; subst;trivial. - rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. - Qed. -(* - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. -Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok. - rewrite Pmul_ok; rsimpl. - Qed. -*) - Lemma PNSubst1_ok: forall n P1 M1 P2 l, - [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. - Proof. - intros n; elim n; simpl; auto. - intros P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. - intros n1 Hrec P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. - Qed. - - Lemma PNSubst_ok: forall n P1 M1 P2 l P3, - PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. - Proof. - intros n P2 (cc, M1) P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); - case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. - intros P5 H1; case n; try (intros; discriminate). - intros n1 H2; injection H2; intros; subst. - rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) - | _ => True - end. - - Lemma PSubstL1_ok: forall n LM1 P1 l, - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; rsimpl. - intros (M2,P2) LM2 Hrec P3 l [H H1]. - rewrite <- Hrec; auto. - apply PNSubst1_ok; auto. - Qed. - - Lemma PSubstL_ok: forall n LM1 P1 P2 l, - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; discriminate. - intros (M2,P2) LM2 Hrec P3 P4 l. - generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). - intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. - rewrite <- PSubstL1_ok; auto. - intros l1 H [H1 H2]; auto. - Qed. - - Lemma PNSubstL_ok: forall m n LM1 P1 l, - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - intros m; elim m; simpl; auto. - intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - intros m1 Hrec n LM1 P2 l H. - generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - rewrite <- Hrec; auto. - 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. - - (** 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 - | 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 : forall p l, nth 0 p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - rewrite <-jump_tl;rewrite nth_jump;rrefl. - rewrite <- nth_jump. - rewrite nth_Pdouble_minus_one;rrefl. - Qed. - - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). - -(* Power using the chinise algorithm *) -(*Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => P - | xO p => subst_l (Psquare (Ppow_pos P p)) - | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok P. - induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - Qed. - - Lemma Ppow_N_ok : forall 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. rrefl. apply Ppow_pos_ok. trivial. Qed. - - End POWER. *) - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => subst_l (Pmul res P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul (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 : forall 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 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. mul_push (P@l);rsimpl. rsimpl. rrefl. - Qed. - - Lemma Ppow_N_ok : forall 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. rrefl. 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 (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). - - (* - Fixpoint norm_subst (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => subst_l (mk_X j) - | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_subst pe1) (norm_subst pe2) - | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) - | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) - | PEopp pe1 => Popp (norm_subst pe1) - | PEpow pe1 n => Ppow_subst (norm_subst pe1) n - end. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). - unfold subst_l;intros. - rewrite <- PNSubstL_ok;trivial. rrefl. - assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). - intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. - induction pe;simpl;Esimpl3. - rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - unfold Ppow_subst. rewrite Ppow_N_ok. trivial. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - Qed. -*) - Lemma norm_aux_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. - rewrite IHpe;rrefl. - rewrite Ppow_N_ok by (intros;rrefl). - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - 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. trivial. - 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 0 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 0 fv) n lm) - | PX P i Q => - let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 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 0 fv) n lm) - | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => - let rP := mult_dev P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else - let lmq := add_pow_list (hd 0 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)). rrefl. - 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 (CRmorph.(morph_eq) _ _ (get_sign_spec.(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 (CRmorph.(morph_eq) _ _ (get_sign_spec.(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 0 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 (Nplus (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - rewrite IHP2. - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - Qed. - - Lemma mult_dev_ok : forall P fv n lm, - mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 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 (Nplus (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. - destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - 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 : - forall (r : R) (p : positive), - 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. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. - - Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. - Proof. - unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. - 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. rewrite <- Heq2;rewrite <- 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 (Pdouble_minus_one 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 (Pdouble_minus_one p) - | xI p => mkmult_pow (-x) x (xO p) - end. - - Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. - Proof. - induction p;intros;simpl;Esimpl. - repeat rewrite IHp;Esimpl. - repeat rewrite IHp;Esimpl. - Qed. - - Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. - Proof. - destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. - Qed. - - Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. - Proof. - destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. - 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. - diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v deleted file mode 100644 index ad20fa08..00000000 --- a/contrib/setoid_ring/Ring_tac.v +++ /dev/null @@ -1,386 +0,0 @@ -Set Implicit Arguments. -Require Import Setoid. -Require Import BinPos. -Require Import Ring_polynom. -Require Import BinList. -Require Import InitialRing. - - -(* adds a definition id' on the normal form of t and an hypothesis id - stating that t = id' (tries to produces a proof as small as possible) *) -Ltac compute_assertion id id' t := - let t' := eval vm_compute in t in - pose (id' := t'); - assert (id : t = id'); - [vm_cast_no_check (refl_equal id')|idtac]. -(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *) - -(********************************************************************) -(* Tacticals to build reflexive tactics *) - -Ltac OnEquation req := - match goal with - | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => fail 1 "Goal is not an equation (of expected equality)" - end. - -Ltac OnMainSubgoal H ty := - match ty with - | _ -> ?ty' => - let subtac := OnMainSubgoal H ty' in - fun tac => lapply H; [clear H; intro H; subtac tac | idtac] - | _ => (fun tac => tac) - end. - -Ltac ApplyLemmaThen lemma expr tac := - let nexpr := fresh "expr_nf" in - let H := fresh "eq_nf" in - let Heq := fresh "thm" in - let nf_spec := - match type of (lemma expr) with - forall x, ?nf_spec = x -> _ => nf_spec - | _ => fail 1 "ApplyLemmaThen: cannot find norm expression" - end in - compute_assertion H nexpr nf_spec; - assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"; - clear H; - OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr). - -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := - let npe := fresh "expr_nf" in - let H := fresh "eq_nf" in - let Heq := fresh "thm" in - let npe_spec := - match type of (lemma expr) with - forall npe, ?npe_spec = npe -> _ => npe_spec - | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" - end in - (compute_assertion H npe npe_spec; - (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"); - clear H; - OnMainSubgoal Heq ltac:(type of Heq) - ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)). - -(* General scheme of reflexive tactics using of correctness lemma - that involves normalisation of one expression *) - -Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_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 cont_arg := - let expr := SYN_tac term fv in - (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in - (* rewrite steps *) - lazy_list_fold_right fcons ltac:(idtac) terms in - LEMMA_tac fv RW_tac. - -(********************************************************) - - -(* Building the atom list of a ring expression *) -Ltac FV Cst CstPow add mul sub opp pow t fv := - let rec TFV t fv := - match Cst t with - | NotConstant => - match t with - | (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 - | (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. - - (* syntaxification of ring expressions *) -Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := - let rec mkP t := - let f := - match Cst t with - | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEadd e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEsub e1 e2) - | (ropp ?t1) => - fun _ => - let e1 := mkP t1 in constr:(PEopp 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 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. - -Ltac ParseRingComponents lemma := - match type of lemma with - | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => - (fun f => f R add mul sub opp pow C) - | _ => fail 1 "ring anomaly: bad correctness lemma (parse)" - end. - -(* ring tactics *) - -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 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 mkPE lH := - let mkHyp h res := - match h with - | @mkhypo (req ?r1 ?r2) _ => - let pe1 := mkPE r1 in - let pe2 := mkPE 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. - -Definition ring_subst_niter := (10*10*10)%nat. - -Ltac Ring Cst_tac CstPow_tac lemma1 req n lH := - let Main lhs rhs R radd rmul rsub ropp rpow C := - let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in - let fv := FV_hypo_tac mkFV req 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_tac C req ltac:(fun t => mkPol t fv) lH in - let vlpe := fresh "hyp_list" in - let vfv := fresh "fv_list" in - pose (vlpe := lpe); - pose (vfv := fv); - (apply (lemma1 n vfv vlpe pe1 pe2) - || fail "typing error while applying ring"); - [ ((let prh := proofHyp_tac lH in exact prh) - || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") - | vm_compute; - (exact (refl_equal true) || fail "not a valid ring equation")] in - ParseRingComponents lemma1 ltac:(OnEquation req Main). - -Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl := - let Main R add mul sub opp pow C := - let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in - let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in - let fv := FV_hypo_tac mkFV req lH in - let simpl_ring H := (protect_fv "ring" in H; f H) in - let lemma_tac fv RW_tac := - let rr_lemma := fresh "r_rw_lemma" in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t 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); - match type of lemma2 with - | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] - => - compute_assertion vlmp_eq vlmp - (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); - (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq) - || fail 1 "type error when build the rewriting lemma"); - RW_tac rr_lemma; - try clear rr_lemma vlmp_eq vlmp vlpe - | _ => fail 1 "ring_simplify anomaly: bad correctness lemma" - end in - ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in - ParseRingComponents lemma2 Main. - - -Ltac Ring_gen - req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl := - pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH. - -Ltac Get_goal := match goal with [|- ?G] => G end. - -Tactic Notation (at level 0) "ring" := - let G := Get_goal in - ring_lookup Ring_gen [] G. - -Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := - let G := Get_goal in - ring_lookup Ring_gen [lH] G. - -(* Simplification *) - -Ltac Ring_simplify_gen f := - fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - let l := fresh "to_rewrite" in - pose (l:= rl); - generalize (refl_equal l); - unfold l at 2; - pre(); - let Tac RL := - let Heq := fresh "Heq" in - intros Heq;clear Heq l; - Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; - post() in - let Main := - match goal with - | [|- l = ?RL -> _ ] => (fun f => f RL) - | _ => fail 1 "ring_simplify anomaly: bad goal after pre" - end in - Main Tac. - -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 Ring_simplify [] rl G. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - ring_lookup Ring_simplify [lH] rl G. - -(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) - -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;clear H; - ring_lookup Ring_simplify [] rl t; - intro 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;clear H; - ring_lookup Ring_simplify [lH] rl t; - intro H; - unfold g;clear g. - - - -(* LE RESTE MARCHE PAS DOMMAGE ..... *) - - - - - - - - - - - - - - - -(* - - - - - - - - -Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp). - - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl G end. - -Tactic Notation (at level 0) - "ring_simplify" constr_list(rl) := - match goal with [|- ?G] => ring_lookup Ring_simplify [] rl G end. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= - let t := type of h in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [lH] rl t. -(* ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *) - -Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp). - -Tactic Notation (at level 0) - "ring_simplify" constr_list(rl) "in" constr(h):= - let t := type of h in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [] rl t. - -Ltac rw_in H Heq := rewrite Heq in H. - -Ltac simpl_in H := - let t := type of H in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [] t. - - -*) diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v deleted file mode 100644 index 531ab3ca..00000000 --- a/contrib/setoid_ring/Ring_theory.v +++ /dev/null @@ -1,608 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Setoid. -Require Import BinPos. -Require Import 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. - -Section Power. - Variable R:Type. - Variable rI : R. - Variable rmul : R -> R -> R. - Variable req : R -> R -> Prop. - Variable Rsth : Setoid_Theory R req. - Notation "x * y " := (rmul x y). - Notation "x == y" := (req x y). - - Hypothesis mul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. - Hypothesis mul_comm : forall x y, x * y == y * x. - Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. - Add Setoid R req Rsth as R_set_Power. - Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed. - - - Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos x i in rmul p p - | xI i => let p := pow_pos x i in rmul x (rmul p p) - end. - - Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j. - Proof. - induction j;simpl. - rewrite IHj. - rewrite (mul_comm x (pow_pos x j *pow_pos x j)). - setoid_rewrite (mul_comm x (pow_pos x j)) at 2. - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - apply (Seq_refl _ _ Rsth). - Qed. - - Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. - Proof. - intro x;induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. - simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc; - simpl. apply (Seq_refl _ _ Rsth). - 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 : forall x n, pow_N x (id_phi_N n) == pow_N x n. - Proof. - intros; apply (Seq_refl _ _ Rsth). - 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. - 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). - - (** 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 : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SRmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2 - }. - - Record ring_eq_ext : Prop := mk_reqe { - (* Ring operators are compatible with equality *) - Radd_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - Rmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 - }. - - (** 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. - Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). - Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). 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 : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid1. - 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. - apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi; - try apply (Seq_refl _ _ Rsth);auto. - Qed. - - (** 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, 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. - 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). - - (** Leibniz equality leads to a setoid theory and is extensional*) - Lemma Eqsth : Setoid_Theory R (@eq R). - Proof. constructor;red;intros;subst;trivial. Qed. - - Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). - Proof. constructor;intros;subst;trivial. Qed. - - Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). - Proof. constructor;intros;subst;trivial. Qed. - - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid2. - Ltac sreflexivity := apply (Seq_refl _ _ Rsth). - - Section SEMI_RING. - Variable SReqe : sring_eq_ext radd rmul req. - Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. - Add Morphism rmul : rmul_ext1. 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. Notation "x - y " := (SRsub x y). - - 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. intros;sreflexivity. Qed. - - Lemma SRopp_add : forall x y, -(x + y) == -x + -y. - Proof. intros;sreflexivity. Qed. - - - Lemma SRsub_def : forall x y, x - y == x + -y. - Proof. intros;sreflexivity. 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. - apply mkmorph;intros;try sreflexivity. unfold IDphi;auto. - 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; intros; constructor; auto. - unfold SRopp in |- *; intros. - setoid_reflexivity. - Qed. - - End SEMI_RING. - - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext2. 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 : forall x, 0 * x == 0. - Proof. - intro x; setoid_replace (0*x) with ((0+1)*x + -x). - rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth). - rewrite (Ropp_def Rth);sreflexivity. - - rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y. - Proof. - intros x y;rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_comm Rth). - rewrite <-(Ropp_def Rth (x*y)). - rewrite (Radd_assoc Rth). - rewrite <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). - rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Ropp_add : forall x y, -(x + y) == -x + -y. - Proof. - intros x y;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);rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). - apply (Radd_comm Rth). - Qed. - - Lemma Ropp_opp : forall x, - -x == x. - Proof. - intros x; rewrite <- (Radd_0_l Rth (- -x)). - rewrite <- (Ropp_def Rth x). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) x);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. - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - Variable Csth : Setoid_Theory C ceq. - Variable Ceqe : ring_eq_ext cadd cmul copp ceq. - Add Setoid C ceq Csth as C_setoid. - Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. - Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. - Add Morphism copp : copp_ext. 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 : phi_ext1. exact phi_ext. Qed. - Lemma Smorph_opp : forall x, [-!x] == -[x]. - Proof. - intros x;rewrite <- (Rth.(Radd_0_l) [-!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])). - apply (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. - Proof. - intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth). - rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. - 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. - - Lemma ARsub_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;sreflexivity. - apply (ARsub_def ARth). - apply (ARsub_def ARth). - Qed. - Add Morphism rsub : rsub_ext. exact ARsub_ext. 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) - | sreflexivity - | match goal with - | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) - end]. - - Lemma ARadd_0_r : forall x, (x + 0) == x. - Proof. intros; mrewrite. Qed. - - Lemma ARmul_1_r : forall x, x * 1 == x. - Proof. intros;mrewrite. Qed. - - Lemma ARmul_0_r : forall x, x * 0 == 0. - Proof. intros;mrewrite. Qed. - - Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. - Proof. - intros;mrewrite. - repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. - Qed. - - Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x. - Proof. - intros;rewrite <-(ARth.(ARadd_assoc) x). - rewrite (ARth.(ARadd_comm) x);sreflexivity. - Qed. - - Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x. - Proof. - intros; repeat rewrite <- (ARadd_assoc ARth); - rewrite ((ARadd_comm ARth) x); sreflexivity. - Qed. - - Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x. - Proof. - intros;rewrite <-((ARmul_assoc ARth) x). - rewrite ((ARmul_comm ARth) x);sreflexivity. - Qed. - - Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. - Proof. - intros; repeat rewrite <- (ARmul_assoc ARth); - rewrite ((ARmul_comm ARth) x); sreflexivity. - Qed. - - Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. - Proof. - intros;rewrite ((ARmul_comm ARth) x y); - rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth). - Qed. - - Lemma ARopp_zero : -0 == 0. - Proof. - rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth). - repeat rewrite ARmul_0_r; sreflexivity. - 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_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) - 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) - end). - diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v deleted file mode 100644 index 942915ab..00000000 --- a/contrib/setoid_ring/ZArithRing.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -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. - -Definition N_of_Z x := - match x with - | Zpos p => Npos p - | _ => N0 - end. - -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 [Zpower _ (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 Zsucc], - power_tac Zpower_theory [Zpow_tac], - (* The two following option are not needed, it is the default chose when the set of - coefficiant is usual ring Z *) - div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), - sign get_signZ_th). - - diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 deleted file mode 100644 index 50b7e47b..00000000 --- a/contrib/setoid_ring/newring.ml4 +++ /dev/null @@ -1,1172 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*) - -open Pp -open Util -open Names -open Term -open Closure -open Environ -open Libnames -open Tactics -open Rawterm -open Termops -open Tacticals -open Tacexpr -open Pcoq -open Tactic -open Constr -open Proof_type -open Coqlib -open Tacmach -open Mod_subst -open Tacinterp -open Libobject -open Printer -open Declare -open Decl_kinds -open Entries - -(****************************************************************************) -(* controlled reduction *) - -let mark_arg i c = mkEvar(i,[|c|]) -let unmark_arg f c = - match destEvar c with - | (i,[|c|]) -> f i c - | _ -> assert false - -type protect_flag = Eval|Prot|Rec - -let tag_arg tag_rec map subs i c = - match map i with - Eval -> mk_clos subs c - | Prot -> mk_atom c - | Rec -> if i = -1 then mk_clos subs c else tag_rec c - -let rec mk_clos_but f_map subs t = - match f_map t with - | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t - | None -> - (match kind_of_term t with - App(f,args) -> mk_clos_app_but f_map subs f args 0 - | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t - | _ -> mk_atom t) - -and mk_clos_app_but f_map subs f args n = - if n >= Array.length args then mk_atom(mkApp(f, args)) - else - let fargs, args' = array_chop n args in - let f' = mkApp(f,fargs) in - match f_map f' with - Some map -> - mk_clos_deep - (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) - subs - (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) - | None -> mk_clos_app_but f_map subs f args (n+1) - - -let interp_map l c = - try - let (im,am) = List.assoc c l in - Some(fun i -> - if List.mem i im then Eval - else if List.mem i am then Prot - else if i = -1 then Eval - else Rec) - with Not_found -> None - -let interp_map l t = - try Some(List.assoc t l) with Not_found -> None - -let protect_maps = ref ([]:(string*(constr->'a)) list) -let add_map s m = protect_maps := (s,m) :: !protect_maps -let lookup_map map = - try List.assoc map !protect_maps - with Not_found -> - errorlabstrm"lookup_map"(str"map "++qs map++str"not found") - -let protect_red map env sigma c = - kl (create_clos_infos betadeltaiota env) - (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);; - -let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; - -let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) - (Some((all_occurrences_expr,id),InHyp));; - - -TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> - [ protect_tac_in map id ] -| [ "protect_fv" string(map) ] -> - [ protect_tac map ] -END;; - -(****************************************************************************) - -let closed_term t l = - let l = List.map constr_of_global l in - let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in - if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) -;; - -TACTIC EXTEND closed_term - [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> - [ closed_term t l ] -END -;; - -TACTIC EXTEND echo -| [ "echo" constr(t) ] -> - [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] -END;; - -(* -let closed_term_ast l = - TacFun([Some(id_of_string"t")], - TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", - [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); - Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) -*) -let closed_term_ast l = - let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in - TacFun([Some(id_of_string"t")], - TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", - [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None); - Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) -(* -let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" -*) - -(****************************************************************************) - -let ic c = - let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c - -let ty c = Typing.type_of (Global.env()) Evd.empty c - -let decl_constant na c = - mkConst(declare_constant (id_of_string na) (DefinitionEntry - { const_entry_body = c; - const_entry_type = None; - const_entry_opaque = true; - const_entry_boxed = true}, - IsProof Lemma)) - -let ltac_call tac (args:glob_tactic_arg list) = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) -let ltac_acall tac (args:glob_tactic_arg list) = - TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args) - -let ltac_lcall tac args = - TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) - -let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) - -let dummy_goal env = - {Evd.it = Evd.make_evar (named_context_val env) mkProp; - Evd.sigma = Evd.empty} - -let exec_tactic env n f args = - let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in - let res = ref [||] in - let get_res ist = - let l = List.map (fun id -> List.assoc id ist.lfun) lid in - res := Array.of_list l; - TacId[] in - let getter = - Tacexp(TacFun(List.map(fun id -> Some id) lid, - glob_tactic(tacticIn get_res))) in - let _ = - Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in - !res - -let constr_of = function - | VConstr c -> c - | _ -> failwith "Ring.exec_tactic: anomaly" - -let stdlib_modules = - [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"]; - ["Coq";"Init";"Logic"]; - ] - -let coq_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) - -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_cons = coq_constant "cons" -let coq_nil = coq_constant "nil" -let coq_None = coq_constant "None" -let coq_Some = coq_constant "Some" -let coq_eq = coq_constant "eq" - -let lapp f args = mkApp(Lazy.force f,args) - -let dest_rel0 t = - match kind_of_term t with - | App(f,args) when Array.length args >= 2 -> - let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in - if closed0 rel then - (rel,args.(Array.length args - 2),args.(Array.length args - 1)) - else error "ring: cannot find relation (not closed)" - | _ -> error "ring: cannot find relation" - -let rec dest_rel t = - match kind_of_term t with - | Prod(_,_,c) -> dest_rel c - | _ -> dest_rel0 t - -(****************************************************************************) -(* Library linking *) - -let contrib_name = "setoid_ring" - -let cdir = ["Coq";contrib_name] -let contrib_modules = - List.map (fun d -> cdir@d) - [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; - ["Field_tac"]; ["Field_theory"] - ] - -let my_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c) - -let new_ring_path = - make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"]) -let ltac s = - lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) -let znew_ring_path = - make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"]) -let zltac s = - lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) - -let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; -let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;; - -(* Ring theory *) - -(* almost_ring defs *) -let coq_almost_ring_theory = my_constant "almost_ring_theory" - -(* setoid and morphism utilities *) -let coq_eq_setoid = my_constant "Eqsth" -let coq_eq_morph = my_constant "Eq_ext" -let coq_eq_smorph = my_constant "Eq_s_ext" - -(* ring -> almost_ring utilities *) -let coq_ring_theory = my_constant "ring_theory" -let coq_mk_reqe = my_constant "mk_reqe" - -(* semi_ring -> almost_ring utilities *) -let coq_semi_ring_theory = my_constant "semi_ring_theory" -let coq_mk_seqe = my_constant "mk_seqe" - -let ltac_inv_morph_gen = zltac"inv_gen_phi" -let ltac_inv_morphZ = zltac"inv_gen_phiZ" -let ltac_inv_morphN = zltac"inv_gen_phiN" -let ltac_inv_morphNword = zltac"inv_gen_phiNword" -let coq_abstract = my_constant"Abstract" -let coq_comp = my_constant"Computational" -let coq_morph = my_constant"Morphism" - -(* morphism *) -let coq_ring_morph = my_constant "ring_morph" -let coq_semi_morph = my_constant "semi_morph" - -(* power function *) -let ltac_inv_morph_nothing = zltac"inv_morph_nothing" -let coq_pow_N_pow_N = my_constant "pow_N_pow_N" - -(* hypothesis *) -let coq_mkhypo = my_constant "mkhypo" -let coq_hypo = my_constant "hypo" - -(* Equality: do not evaluate but make recursive call on both sides *) -let map_with_eq arg_map c = - let (req,_,_) = dest_rel c in - interp_map - ((req,(function -1->Prot|_->Rec)):: - List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) - -let _ = add_map "ring" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect - ring operations and make recursive call on the var map *) - pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring - operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) - -(****************************************************************************) -(* Ring database *) - -type ring_info = - { ring_carrier : types; - ring_req : constr; - ring_setoid : constr; - ring_ext : constr; - ring_morph : constr; - ring_th : constr; - ring_cst_tac : glob_tactic_expr; - ring_pow_tac : glob_tactic_expr; - ring_lemma1 : constr; - ring_lemma2 : constr; - ring_pre_tac : glob_tactic_expr; - ring_post_tac : glob_tactic_expr } - -module Cmap = Map.Make(struct type t = constr let compare = compare end) - -let from_carrier = ref Cmap.empty -let from_relation = ref Cmap.empty -let from_name = ref Spmap.empty - -let ring_for_carrier r = Cmap.find r !from_carrier -let ring_for_relation rel = Cmap.find rel !from_relation -let ring_lookup_by_name ref = - Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name - - -let find_ring_structure env sigma l oname = - match oname, l with - Some rf, _ -> - (try ring_lookup_by_name rf - with Not_found -> - errorlabstrm "ring" - (str "found no ring named "++pr_reference rf)) - | None, t::cl' -> - let ty = Retyping.get_type_of env sigma t in - let check c = - let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "ring" - (str"arguments of ring_simplify do not have all the same type") - in - List.iter check cl'; - (try ring_for_carrier ty - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> assert false -(* - let (req,_,_) = dest_rel cl in - (try ring_for_relation req - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) *) - -let _ = - Summary.declare_summary "tactic-new-ring-table" - { Summary.freeze_function = - (fun () -> !from_carrier,!from_relation,!from_name); - Summary.unfreeze_function = - (fun (ct,rt,nt) -> - from_carrier := ct; from_relation := rt; from_name := nt); - Summary.init_function = - (fun () -> - from_carrier := Cmap.empty; from_relation := Cmap.empty; - from_name := Spmap.empty); - Summary.survive_module = false; - Summary.survive_section = false } - -let add_entry (sp,_kn) e = -(* let _ = ty e.ring_lemma1 in - let _ = ty e.ring_lemma2 in -*) - from_carrier := Cmap.add e.ring_carrier e !from_carrier; - from_relation := Cmap.add e.ring_req e !from_relation; - from_name := Spmap.add sp e !from_name - - -let subst_th (_,subst,th) = - let c' = subst_mps subst th.ring_carrier in - let eq' = subst_mps subst th.ring_req in - let set' = subst_mps subst th.ring_setoid in - let ext' = subst_mps subst th.ring_ext in - let morph' = subst_mps subst th.ring_morph in - let th' = subst_mps subst th.ring_th in - let thm1' = subst_mps subst th.ring_lemma1 in - let thm2' = subst_mps subst th.ring_lemma2 in - let tac'= subst_tactic subst th.ring_cst_tac in - let pow_tac'= subst_tactic subst th.ring_pow_tac in - let pretac'= subst_tactic subst th.ring_pre_tac in - let posttac'= subst_tactic subst th.ring_post_tac in - if c' == th.ring_carrier && - eq' == th.ring_req && - set' = th.ring_setoid && - ext' == th.ring_ext && - morph' == th.ring_morph && - th' == th.ring_th && - thm1' == th.ring_lemma1 && - thm2' == th.ring_lemma2 && - tac' == th.ring_cst_tac && - pow_tac' == th.ring_pow_tac && - pretac' == th.ring_pre_tac && - posttac' == th.ring_post_tac then th - else - { ring_carrier = c'; - ring_req = eq'; - ring_setoid = set'; - ring_ext = ext'; - ring_morph = morph'; - ring_th = th'; - ring_cst_tac = tac'; - ring_pow_tac = pow_tac'; - ring_lemma1 = thm1'; - ring_lemma2 = thm2'; - ring_pre_tac = pretac'; - ring_post_tac = posttac' } - - -let (theory_to_obj, obj_to_theory) = - let cache_th (name,th) = add_entry name th - and export_th x = Some x in - declare_object - {(default_object "tactic-new-ring-theory") with - open_function = (fun i o -> if i=1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_th } - - -let setoid_of_relation env a r = - let evm = Evd.empty in - try - lapp coq_mk_Setoid - [|a ; r ; - Class_tactics.get_reflexive_proof env evm a r ; - Class_tactics.get_symmetric_proof env evm a r ; - Class_tactics.get_transitive_proof env evm a r |] - with Not_found -> - error "cannot find setoid relation" - -let op_morph r add mul opp req m1 m2 m3 = - lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] - -let op_smorph r add mul req m1 m2 = - lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] - -(* let default_ring_equality (r,add,mul,opp,req) = *) -(* let is_setoid = function *) -(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr req rel (\* Qu: use conversion ? *\) *) -(* | _ -> false in *) -(* match default_relation_for_carrier ~filter:is_setoid r with *) -(* Leibniz _ -> *) -(* let setoid = lapp coq_eq_setoid [|r|] in *) -(* let op_morph = *) -(* match opp with *) -(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) -(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) -(* (setoid,op_morph) *) -(* | Relation rel -> *) -(* let setoid = setoid_of_relation rel in *) -(* let is_endomorphism = function *) -(* { args=args } -> List.for_all *) -(* (function (var,Relation rel) -> *) -(* var=None && eq_constr req rel *) -(* | _ -> false) args in *) -(* let add_m = *) -(* try default_morphism ~filter:is_endomorphism add *) -(* with Not_found -> *) -(* error "ring addition should be declared as a morphism" in *) -(* let mul_m = *) -(* try default_morphism ~filter:is_endomorphism mul *) -(* with Not_found -> *) -(* error "ring multiplication should be declared as a morphism" in *) -(* let op_morph = *) -(* match opp with *) -(* | Some opp -> *) -(* (let opp_m = *) -(* try default_morphism ~filter:is_endomorphism opp *) -(* with Not_found -> *) -(* error "ring opposite should be declared as a morphism" in *) -(* let op_morph = *) -(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) -(* msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) -(* str"\""); *) -(* op_morph) *) -(* | None -> *) -(* (msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++ *) -(* pr_constr mul_m.morphism_theory++str"\""); *) -(* op_smorph r add mul req add_m.lem mul_m.lem) in *) -(* (setoid,op_morph) *) - -let ring_equality (r,add,mul,opp,req) = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - let setoid = lapp coq_eq_setoid [|r|] in - let op_morph = - match opp with - Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] - | None -> lapp coq_eq_smorph [|r;add;mul|] in - (setoid,op_morph) - | _ -> - let setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in - let add_m, add_m_lem = - try Class_tactics.default_morphism signature add - with Not_found -> - error "ring addition should be declared as a morphism" in - let mul_m, mul_m_lem = - try Class_tactics.default_morphism signature mul - with Not_found -> - error "ring multiplication should be declared as a morphism" in - let op_morph = - match opp with - | Some opp -> - (let opp_m,opp_m_lem = - try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (r,req))) opp - with Not_found -> - error "ring opposite should be declared as a morphism" in - let op_morph = - op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in - Flags.if_verbose - msgnl - (str"Using setoid \""++pr_constr req++str"\""++spc()++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\","++spc()++ str"\""++pr_constr mul_m_lem++ - str"\""++spc()++str"and \""++pr_constr opp_m_lem++ - str"\""); - op_morph) - | None -> - (Flags.if_verbose - msgnl - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\""++spc()++str"and \""++ - pr_constr mul_m_lem++str"\""); - op_smorph r add mul req add_m_lem mul_m_lem) in - (setoid,op_morph) - -let build_setoid_params r add mul opp req eqth = - match eqth with - Some th -> th - | None -> ring_equality (r,add,mul,opp,req) - -let dest_ring env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in - match kind_of_term th_typ with - App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when f = Lazy.force coq_almost_ring_theory -> - (None,r,zero,one,add,mul,Some sub,Some opp,req) - | App(f,[|r;zero;one;add;mul;req|]) - when f = Lazy.force coq_semi_ring_theory -> - (Some true,r,zero,one,add,mul,None,None,req) - | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when f = Lazy.force coq_ring_theory -> - (Some false,r,zero,one,add,mul,Some sub,Some opp,req) - | _ -> error "bad ring structure" - - -let dest_morph env sigma m_spec = - let m_typ = Retyping.get_type_of env sigma m_spec in - match kind_of_term m_typ with - App(f,[|r;zero;one;add;mul;sub;opp;req; - c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when f = Lazy.force coq_ring_morph -> - (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) - | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when f = Lazy.force coq_semi_morph -> - (c,czero,cone,cadd,cmul,None,None,ceqb,phi) - | _ -> error "bad morphism structure" - - -type coeff_spec = - Computational of constr (* equality test *) - | Abstract (* coeffs = Z *) - | Morphism of constr (* general morphism *) - - -let reflect_coeff rkind = - (* We build an ill-typed terms on purpose... *) - match rkind with - Abstract -> Lazy.force coq_abstract - | Computational c -> lapp coq_comp [|c|] - | Morphism m -> lapp coq_morph [|m|] - -type cst_tac_spec = - CstTac of raw_tactic_expr - | Closed of reference list - -let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = - match cst_tac with - Some (CstTac t) -> Tacinterp.glob_tactic t - | Some (Closed lc) -> - closed_term_ast (List.map Syntax_def.global_with_alias lc) - | None -> - (match rk, opp, kind with - Abstract, None, _ -> - let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) - | Abstract, Some opp, Some _ -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | Abstract, Some opp, None -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | Computational _,_,_ -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) - | Morphism mth,_,_ -> - let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) - -let make_hyp env c = - let t = Retyping.get_type_of env Evd.empty c in - lapp coq_mkhypo [|t;c|] - -let make_hyp_list env lH = - let carrier = Lazy.force coq_hypo in - List.fold_right - (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH - (lapp coq_nil [|carrier|]) - -let interp_power env pow = - let carrier = Lazy.force coq_hypo in - match pow with - | None -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in - (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) - | Some (tac, spec) -> - let tac = - match tac with - | CstTac t -> Tacinterp.glob_tactic t - | Closed lc -> - closed_term_ast (List.map Syntax_def.global_with_alias lc) in - let spec = make_hyp env (ic spec) in - (tac, lapp coq_Some [|carrier; spec|]) - -let interp_sign env sign = - let carrier = Lazy.force coq_hypo in - match sign with - | None -> lapp coq_None [|carrier|] - | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] - (* Same remark on ill-typed terms ... *) - -let interp_div env div = - let carrier = Lazy.force coq_hypo in - match div with - | None -> lapp coq_None [|carrier|] - | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] - (* Same remark on ill-typed terms ... *) - -let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = - check_required_library (cdir@["Ring_base"]); - let env = Global.env() in - let sigma = Evd.empty in - let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env div in - let rk = reflect_coeff morphth in - let params = - exec_tactic env 5 (zltac "ring_lemmas") - (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - - let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in - let cst_tac = - interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in - let pretac = - match pre with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let posttac = - match post with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let _ = - Lib.add_leaf name - (theory_to_obj - { ring_carrier = r; - ring_req = req; - ring_setoid = sth; - ring_ext = constr_of params.(1); - ring_morph = constr_of params.(2); - ring_th = constr_of params.(0); - ring_cst_tac = cst_tac; - ring_pow_tac = pow_tac; - ring_lemma1 = lemma1; - ring_lemma2 = lemma2; - ring_pre_tac = pretac; - ring_post_tac = posttac }) in - () - -type ring_mod = - Ring_kind of coeff_spec - | Const_tac of cst_tac_spec - | Pre_tac of raw_tactic_expr - | Post_tac of raw_tactic_expr - | Setoid of Topconstr.constr_expr * Topconstr.constr_expr - | Pow_spec of cst_tac_spec * Topconstr.constr_expr - (* Syntaxification tactic , correctness lemma *) - | Sign_spec of Topconstr.constr_expr - | Div_spec of Topconstr.constr_expr - - -VERNAC ARGUMENT EXTEND ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] - | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] - | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] - | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] - | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] - | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] - | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] - | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] - | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> - [ Pow_spec (Closed l, pow_spec) ] - | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> - [ Pow_spec (CstTac cst_tac, pow_spec) ] - | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] -END - -let set_once s r v = - if !r = None then r := Some v else error (s^" cannot be set twice") - -let process_ring_mods l = - let kind = ref None in - let set = ref None in - let cst_tac = ref None in - let pre = ref None in - let post = ref None in - let sign = ref None in - let power = ref None in - let div = ref None in - List.iter(function - Ring_kind k -> set_once "ring kind" kind k - | Const_tac t -> set_once "tactic recognizing constants" cst_tac t - | Pre_tac t -> set_once "preprocess tactic" pre t - | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) - | Pow_spec(t,spec) -> set_once "power" power (t,spec) - | Sign_spec t -> set_once "sign" sign t - | Div_spec t -> set_once "div" div t) l; - let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) - -VERNAC COMMAND EXTEND AddSetoidRing - | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory id (ic t) set k cst (pre,post) power sign div] -END - -(*****************************************************************************) -(* The tactics consist then only in a lookup in the ring database and - call the appropriate ltac. *) - -let make_args_list rl t = - match rl with - | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] - | _ -> rl - -let make_term_list carrier rl = - List.fold_right - (fun x l -> lapp coq_cons [|carrier;x;l|]) rl - (lapp coq_nil [|carrier|]) - - -let ring_lookup (f:glob_tactic_expr) lH rl t gl = - let env = pf_env gl in - let sigma = project gl in - let rl = make_args_list rl t in - let e = find_ring_structure env sigma rl None in - let rl = carg (make_term_list e.ring_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let req = carg e.ring_req in - let sth = carg e.ring_setoid in - let ext = carg e.ring_ext in - let morph = carg e.ring_morph in - let th = carg e.ring_th in - let cst_tac = Tacexp e.ring_cst_tac in - let pow_tac = Tacexp e.ring_pow_tac in - let lemma1 = carg e.ring_lemma1 in - let lemma2 = carg e.ring_lemma2 in - let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in - Tacinterp.eval_tactic - (TacLetIn - (false,[(dummy_loc,id_of_string"f"),Tacexp f], - ltac_lcall "f" - [req;sth;ext;morph;th;cst_tac;pow_tac; - lemma1;lemma2;pretac;posttac;lH;rl])) gl - -TACTIC EXTEND ring_lookup -| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t] -END - - - -(***********************************************************************) - -let new_field_path = - make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"]) - -let field_ltac s = - lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) - - -let _ = add_map "field" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* display_linear: evaluate polynomials and coef operations, protect - field operations and make recursive call on the var map *) - my_constant "display_linear", - (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); - my_constant "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect - ring operations and make recursive call on the var map *) - pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring - operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); - (* FEeval: evaluate morphism, protect field - operations and make recursive call on the var map *) - my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; - -let _ = add_map "field_cond" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring - operations and make recursive call on the var map *) - my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);; -(* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*) - - -let afield_theory = my_constant "almost_field_theory" -let field_theory = my_constant "field_theory" -let sfield_theory = my_constant "semi_field_theory" -let af_ar = my_constant"AF_AR" -let f_r = my_constant"F_R" -let sf_sr = my_constant"SF_SR" -let dest_field env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in - match kind_of_term th_typ with - | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when f = Lazy.force afield_theory -> - let rth = lapp af_ar - [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in - (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) - | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when f = Lazy.force field_theory -> - let rth = - lapp f_r - [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in - (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) - | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when f = Lazy.force sfield_theory -> - let rth = lapp sf_sr - [|r;zero;one;add;mul;div;inv;req;th_spec|] in - (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) - | _ -> error "bad field structure" - -type field_info = - { field_carrier : types; - field_req : constr; - field_cst_tac : glob_tactic_expr; - field_pow_tac : glob_tactic_expr; - field_ok : constr; - field_simpl_eq_ok : constr; - field_simpl_ok : constr; - field_simpl_eq_in_ok : constr; - field_cond : constr; - field_pre_tac : glob_tactic_expr; - field_post_tac : glob_tactic_expr } - -let field_from_carrier = ref Cmap.empty -let field_from_relation = ref Cmap.empty -let field_from_name = ref Spmap.empty - - -let field_for_carrier r = Cmap.find r !field_from_carrier -let field_for_relation rel = Cmap.find rel !field_from_relation -let field_lookup_by_name ref = - Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) - !field_from_name - - -let find_field_structure env sigma l oname = - check_required_library (cdir@["Field_tac"]); - match oname, l with - Some rf, _ -> - (try field_lookup_by_name rf - with Not_found -> - errorlabstrm "field" - (str "found no field named "++pr_reference rf)) - | None, t::cl' -> - let ty = Retyping.get_type_of env sigma t in - let check c = - let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "field" - (str"arguments of field_simplify do not have all the same type") - in - List.iter check cl'; - (try field_for_carrier ty - with Not_found -> - errorlabstrm "field" - (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> assert false -(* let (req,_,_) = dest_rel cl in - (try field_for_relation req - with Not_found -> - errorlabstrm "field" - (str"cannot find a declared field structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) *) - -let _ = - Summary.declare_summary "tactic-new-field-table" - { Summary.freeze_function = - (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); - Summary.unfreeze_function = - (fun (ct,rt,nt) -> - field_from_carrier := ct; field_from_relation := rt; - field_from_name := nt); - Summary.init_function = - (fun () -> - field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty; - field_from_name := Spmap.empty); - Summary.survive_module = false; - Summary.survive_section = false } - -let add_field_entry (sp,_kn) e = -(* - let _ = ty e.field_ok in - let _ = ty e.field_simpl_eq_ok in - let _ = ty e.field_simpl_ok in - let _ = ty e.field_cond in -*) - field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; - field_from_relation := Cmap.add e.field_req e !field_from_relation; - field_from_name := Spmap.add sp e !field_from_name - -let subst_th (_,subst,th) = - let c' = subst_mps subst th.field_carrier in - let eq' = subst_mps subst th.field_req in - let thm1' = subst_mps subst th.field_ok in - let thm2' = subst_mps subst th.field_simpl_eq_ok in - let thm3' = subst_mps subst th.field_simpl_ok in - let thm4' = subst_mps subst th.field_simpl_eq_in_ok in - let thm5' = subst_mps subst th.field_cond in - let tac'= subst_tactic subst th.field_cst_tac in - let pow_tac' = subst_tactic subst th.field_pow_tac in - let pretac'= subst_tactic subst th.field_pre_tac in - let posttac'= subst_tactic subst th.field_post_tac in - if c' == th.field_carrier && - eq' == th.field_req && - thm1' == th.field_ok && - thm2' == th.field_simpl_eq_ok && - thm3' == th.field_simpl_ok && - thm4' == th.field_simpl_eq_in_ok && - thm5' == th.field_cond && - tac' == th.field_cst_tac && - pow_tac' == th.field_pow_tac && - pretac' == th.field_pre_tac && - posttac' == th.field_post_tac then th - else - { field_carrier = c'; - field_req = eq'; - field_cst_tac = tac'; - field_pow_tac = pow_tac'; - field_ok = thm1'; - field_simpl_eq_ok = thm2'; - field_simpl_ok = thm3'; - field_simpl_eq_in_ok = thm4'; - field_cond = thm5'; - field_pre_tac = pretac'; - field_post_tac = posttac' } - -let (ftheory_to_obj, obj_to_ftheory) = - let cache_th (name,th) = add_field_entry name th - and export_th x = Some x in - declare_object - {(default_object "tactic-new-field-theory") with - open_function = (fun i o -> if i=1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_th } - -let field_equality r inv req = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) - | _ -> - let _setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in - let inv_m, inv_m_lem = - try Class_tactics.default_morphism signature inv - with Not_found -> - error "field inverse should be declared as a morphism" in - inv_m_lem - -let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = - check_required_library (cdir@["Field_tac"]); - let env = Global.env() in - let sigma = Evd.empty in - let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env sigma fth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let eqth = Some(sth,ext) in - let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env odiv in - let inv_m = field_equality r inv req in - let rk = reflect_coeff morphth in - let params = - exec_tactic env 9 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - let lemma3 = constr_of params.(5) in - let lemma4 = constr_of params.(6) in - let cond_lemma = - match inj with - | Some thm -> mkApp(constr_of params.(8),[|thm|]) - | None -> constr_of params.(7) in - let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in - let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in - let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in - let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in - let cst_tac = - interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in - let pretac = - match pre with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let posttac = - match post with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let _ = - Lib.add_leaf name - (ftheory_to_obj - { field_carrier = r; - field_req = req; - field_cst_tac = cst_tac; - field_pow_tac = pow_tac; - field_ok = lemma1; - field_simpl_eq_ok = lemma2; - field_simpl_ok = lemma3; - field_simpl_eq_in_ok = lemma4; - field_cond = cond_lemma; - field_pre_tac = pretac; - field_post_tac = posttac }) in () - -type field_mod = - Ring_mod of ring_mod - | Inject of Topconstr.constr_expr - -VERNAC ARGUMENT EXTEND field_mod - | [ ring_mod(m) ] -> [ Ring_mod m ] - | [ "completeness" constr(inj) ] -> [ Inject inj ] -END - -let process_field_mods l = - let kind = ref None in - let set = ref None in - let cst_tac = ref None in - let pre = ref None in - let post = ref None in - let inj = ref None in - let sign = ref None in - let power = ref None in - let div = ref None in - List.iter(function - Ring_mod(Ring_kind k) -> set_once "field kind" kind k - | Ring_mod(Const_tac t) -> - set_once "tactic recognizing constants" cst_tac t - | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t - | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) - | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) - | Ring_mod(Sign_spec t) -> set_once "sign" sign t - | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic i)) l; - let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) - -VERNAC COMMAND EXTEND AddSetoidField -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in - add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] -END - -let field_lookup (f:glob_tactic_expr) lH rl t gl = - let env = pf_env gl in - let sigma = project gl in - let rl = make_args_list rl t in - let e = find_field_structure env sigma rl None in - let rl = carg (make_term_list e.field_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let req = carg e.field_req in - let cst_tac = Tacexp e.field_cst_tac in - let pow_tac = Tacexp e.field_pow_tac in - let field_ok = carg e.field_ok in - let field_simpl_ok = carg e.field_simpl_ok in - let field_simpl_eq_ok = carg e.field_simpl_eq_ok in - let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in - let cond_ok = carg e.field_cond in - let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.field_post_tac)) in - Tacinterp.eval_tactic - (TacLetIn - (false,[(dummy_loc,id_of_string"f"),Tacexp f], - ltac_lcall "f" - [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; - field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl - -TACTIC EXTEND field_lookup -| [ "field_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] -END |