diff options
| author |  Robert Sloan <varomodt@gmail.com> | 2016-06-22 14:06:28 -0400 |
|---|---|---|
| committer | Robert Sloan <varomodt@gmail.com> | 2016-06-22 14:06:28 -0400 |
| commit | 2f44fe53e1a598b524e11cda3dc9ce7a04534247 (patch) | |
| tree | 47a77eb4ed8fea3ac5ec99c5bf5ad9131ba44fd9 | |
| parent | e101fc5dd8783d029d7a4933c7ccca4a67ed3874 (diff) | |
| parent | 3d8afe1c9bd905e3a62523e87a2aa7e5d9f5093d (diff) | |
Merge with plv/master
78 files changed, 12692 insertions, 2754 deletions
diff --git a/.gitignore b/.gitignore index 6caadcb20..9028c237e 100644 --- a/.gitignore +++ b/.gitignore @@ -5,5 +5,7 @@ fiat *.vo *.d *.glob +*.aux +*.vio Makefile.coq Makefile.bak diff --git a/.mailmap b/.mailmap new file mode 100644 index 000000000..c170ccdca --- /dev/null +++ b/.mailmap @@ -0,0 +1,19 @@ +## This file allows joining different accounts of a single person. +## Cf for instance: git shortlog -nse. More details via: man git shortlog + +# having the same name <email> name <email> on a line will fix capitalization +Adam Chlipala <adamc@csail.mit.edu> Adam Chlipala <adamc@csail.mit.edu> +Adam Chlipala <adamc@csail.mit.edu> Adam Chlipala <adam@chlipala.net> +Andres Erbsen <andreser@mit.edu> Andres Erbsen <andreser@mit.edu> +Jade Philipoom <jadep@mit.edu> Jade Philipoom <jadep@mit.edu> +Jade Philipoom <jadep@mit.edu> jadep <jade.philipoom@gmail.com> +Jade Philipoom <jadep@mit.edu> jadep <jadep@mit.edu> +Jason Gross <jgross@mit.edu> Jason Gross <jgross@mit.edu> +Jason Gross <jgross@mit.edu> Jason Gross <jagro@google.com> +Robert Sloan <varomodt@gmail.com> Robert Sloan <rsloan@sumologic.com> +Robert Sloan <varomodt@gmail.com> Robert Sloan <varomodt@dhcp-18-189-26-21.dyn.MIT.EDU> +Robert Sloan <varomodt@gmail.com> Robert Sloan <varomodt@dhcp-18-189-51-40.dyn.MIT.EDU> +Robert Sloan <varomodt@gmail.com> Robert Sloan <varomodt@gmail.com> +Robert Sloan <varomodt@gmail.com> Robert Sloan <varomodt@Roberts-MacBook.local> +Robert Sloan <varomodt@gmail.com> Rob Sloan <varomodt@gmail.com> +Robert Sloan <varomodt@gmail.com> varomodt <varomodt@localhost.localdomain> diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..9bea40d88 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,11 @@ +language: generic + +sudo: required +dist: trusty + +addons: + apt: + packages: + - coq + +script: make COQPATH="$(pwd)/coqprime" TIMED=1 -j2 diff --git a/Bedrock/Nomega.v b/Bedrock/Nomega.v new file mode 100644 index 000000000..5f39f832f --- /dev/null +++ b/Bedrock/Nomega.v @@ -0,0 +1,73 @@ +(* Make [omega] work for [N] *) + +Require Import Coq.Arith.Arith Coq.omega.Omega Coq.NArith.NArith. + +Global Set Asymmetric Patterns. + +Local Open Scope N_scope. + +Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus + N_of_nat_of_N nat_of_N_of_nat + nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N. + +Theorem nat_of_N_eq : forall n m, + nat_of_N n = nat_of_N m + -> n = m. + intros ? ? H; apply (f_equal N_of_nat) in H; + autorewrite with N in *; assumption. +Qed. + +Theorem Nneq_in : forall n m, + nat_of_N n <> nat_of_N m + -> n <> m. + congruence. +Qed. + +Theorem Nneq_out : forall n m, + n <> m + -> nat_of_N n <> nat_of_N m. + intuition. + apply nat_of_N_eq in H0; tauto. +Qed. + +Theorem Nlt_out : forall n m, n < m + -> (nat_of_N n < nat_of_N m)%nat. + unfold Nlt; intros. + rewrite nat_of_Ncompare in H. + apply nat_compare_Lt_lt; assumption. +Qed. + +Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat + -> n < m. + unfold Nlt; intros. + rewrite nat_of_Ncompare. + apply (proj1 (nat_compare_lt _ _)); assumption. +Qed. + +Theorem Nge_out : forall n m, n >= m + -> (nat_of_N n >= nat_of_N m)%nat. + unfold Nge; intros. + rewrite nat_of_Ncompare in H. + apply nat_compare_ge; assumption. +Qed. + +Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat + -> n >= m. + unfold Nge; intros. + rewrite nat_of_Ncompare. + apply nat_compare_ge; assumption. +Qed. + +Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H). + +Ltac pre_nomega := + try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl; + repeat (progress autorewrite with N; simpl); + repeat match goal with + | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H + | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H + | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H + || apply Nlt_out in H || apply Nge_out in H); nsimp H + end. + +Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega). diff --git a/Bedrock/Word.v b/Bedrock/Word.v new file mode 100644 index 000000000..8ae651826 --- /dev/null +++ b/Bedrock/Word.v @@ -0,0 +1,1178 @@ +(** Fixed precision machine words *) + +Require Import Coq.Arith.Arith Coq.Arith.Div2 Coq.NArith.NArith Coq.Bool.Bool Coq.omega.Omega. +Require Import Bedrock.Nomega. + +Set Implicit Arguments. + + +(** * Basic definitions and conversion to and from [nat] *) + +Inductive word : nat -> Set := +| WO : word O +| WS : bool -> forall n, word n -> word (S n). + +Fixpoint wordToNat sz (w : word sz) : nat := + match w with + | WO => O + | WS false _ w' => (wordToNat w') * 2 + | WS true _ w' => S (wordToNat w' * 2) + end. + +Fixpoint wordToNat' sz (w : word sz) : nat := + match w with + | WO => O + | WS false _ w' => 2 * wordToNat w' + | WS true _ w' => S (2 * wordToNat w') + end. + +Theorem wordToNat_wordToNat' : forall sz (w : word sz), + wordToNat w = wordToNat' w. +Proof. + induction w. auto. simpl. rewrite mult_comm. reflexivity. +Qed. + +Fixpoint mod2 (n : nat) : bool := + match n with + | 0 => false + | 1 => true + | S (S n') => mod2 n' + end. + +Fixpoint natToWord (sz n : nat) : word sz := + match sz with + | O => WO + | S sz' => WS (mod2 n) (natToWord sz' (div2 n)) + end. + +Fixpoint wordToN sz (w : word sz) : N := + match w with + | WO => 0 + | WS false _ w' => 2 * wordToN w' + | WS true _ w' => Nsucc (2 * wordToN w') + end%N. + +Definition Nmod2 (n : N) : bool := + match n with + | N0 => false + | Npos (xO _) => false + | _ => true + end. + +Definition wzero sz := natToWord sz 0. + +Fixpoint wzero' (sz : nat) : word sz := + match sz with + | O => WO + | S sz' => WS false (wzero' sz') + end. + +Fixpoint posToWord (sz : nat) (p : positive) {struct p} : word sz := + match sz with + | O => WO + | S sz' => + match p with + | xI p' => WS true (posToWord sz' p') + | xO p' => WS false (posToWord sz' p') + | xH => WS true (wzero' sz') + end + end. + +Definition NToWord (sz : nat) (n : N) : word sz := + match n with + | N0 => wzero' sz + | Npos p => posToWord sz p + end. + +Fixpoint Npow2 (n : nat) : N := + match n with + | O => 1 + | S n' => 2 * Npow2 n' + end%N. + + +Ltac rethink := + match goal with + | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto + end. + +Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true. + induction n; simpl; intuition; rethink. +Qed. + +Theorem mod2_double : forall n, mod2 (2 * n) = false. + induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink. +Qed. + +Local Hint Resolve mod2_S_double mod2_double. + +Theorem div2_double : forall n, div2 (2 * n) = n. + induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink. +Qed. + +Theorem div2_S_double : forall n, div2 (S (2 * n)) = n. + induction n; simpl; intuition; f_equal; rethink. +Qed. + +Hint Rewrite div2_double div2_S_double : div2. + +Theorem natToWord_wordToNat : forall sz w, natToWord sz (wordToNat w) = w. + induction w; rewrite wordToNat_wordToNat'; intuition; f_equal; unfold natToWord, wordToNat'; fold natToWord; fold wordToNat'; + destruct b; f_equal; autorewrite with div2; intuition. +Qed. + +Fixpoint pow2 (n : nat) : nat := + match n with + | O => 1 + | S n' => 2 * pow2 n' + end. + +Theorem roundTrip_0 : forall sz, wordToNat (natToWord sz 0) = 0. + induction sz; simpl; intuition. +Qed. + +Hint Rewrite roundTrip_0 : wordToNat. + +Local Hint Extern 1 (@eq nat _ _) => omega. + +Theorem untimes2 : forall n, n + (n + 0) = 2 * n. + auto. +Qed. + +Section strong. + Variable P : nat -> Prop. + + Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n. + + Lemma strong' : forall n m, m <= n -> P m. + induction n; simpl; intuition; apply PH; intuition. + elimtype False; omega. + Qed. + + Theorem strong : forall n, P n. + intros; eapply strong'; eauto. + Qed. +End strong. + +Theorem div2_odd : forall n, + mod2 n = true + -> n = S (2 * div2 n). + induction n using strong; simpl; intuition. + + destruct n; simpl in *; intuition. + discriminate. + destruct n; simpl in *; intuition. + do 2 f_equal. + replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto. +Qed. + +Theorem div2_even : forall n, + mod2 n = false + -> n = 2 * div2 n. + induction n using strong; simpl; intuition. + + destruct n; simpl in *; intuition. + destruct n; simpl in *; intuition. + discriminate. + f_equal. + replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto. +Qed. + +Lemma wordToNat_natToWord' : forall sz w, exists k, wordToNat (natToWord sz w) + k * pow2 sz = w. + induction sz; simpl; intuition; repeat rewrite untimes2. + + exists w; intuition. + + case_eq (mod2 w); intro Hmw. + + specialize (IHsz (div2 w)); firstorder. + rewrite wordToNat_wordToNat' in *. + exists x; intuition. + rewrite mult_assoc. + rewrite (mult_comm x 2). + rewrite mult_comm. simpl mult at 1. + rewrite (plus_Sn_m (2 * wordToNat' (natToWord sz (div2 w)))). + rewrite <- mult_assoc. + rewrite <- mult_plus_distr_l. + rewrite H; clear H. + symmetry; apply div2_odd; auto. + + specialize (IHsz (div2 w)); firstorder. + exists x; intuition. + rewrite mult_assoc. + rewrite (mult_comm x 2). + rewrite <- mult_assoc. + rewrite mult_comm. + rewrite <- mult_plus_distr_l. + rewrite H; clear H. + symmetry; apply div2_even; auto. +Qed. + +Theorem wordToNat_natToWord : forall sz w, exists k, wordToNat (natToWord sz w) = w - k * pow2 sz /\ k * pow2 sz <= w. + intros; destruct (wordToNat_natToWord' sz w) as [k]; exists k; intuition. +Qed. + +Definition wone sz := natToWord sz 1. + +Fixpoint wones (sz : nat) : word sz := + match sz with + | O => WO + | S sz' => WS true (wones sz') + end. + + +(** Comparisons *) + +Fixpoint wmsb sz (w : word sz) (a : bool) : bool := + match w with + | WO => a + | WS b _ x => wmsb x b + end. + +Definition whd sz (w : word (S sz)) : bool := + match w in word sz' return match sz' with + | O => unit + | S _ => bool + end with + | WO => tt + | WS b _ _ => b + end. + +Definition wtl sz (w : word (S sz)) : word sz := + match w in word sz' return match sz' with + | O => unit + | S sz'' => word sz'' + end with + | WO => tt + | WS _ _ w' => w' + end. + +Theorem WS_neq : forall b1 b2 sz (w1 w2 : word sz), + (b1 <> b2 \/ w1 <> w2) + -> WS b1 w1 <> WS b2 w2. + intuition. + apply (f_equal (@whd _)) in H0; tauto. + apply (f_equal (@wtl _)) in H0; tauto. +Qed. + + +(** Shattering **) + +Lemma shatter_word : forall n (a : word n), + match n return word n -> Prop with + | O => fun a => a = WO + | S _ => fun a => a = WS (whd a) (wtl a) + end a. + destruct a; eauto. +Qed. + +Lemma shatter_word_S : forall n (a : word (S n)), + exists b, exists c, a = WS b c. +Proof. + intros; repeat eexists; apply (shatter_word a). +Qed. +Lemma shatter_word_0 : forall a : word 0, + a = WO. +Proof. + intros; apply (shatter_word a). +Qed. + +Hint Resolve shatter_word_0. + +Require Import Coq.Logic.Eqdep_dec. + +Definition weq : forall sz (x y : word sz), {x = y} + {x <> y}. + refine (fix weq sz (x : word sz) : forall y : word sz, {x = y} + {x <> y} := + match x in word sz return forall y : word sz, {x = y} + {x <> y} with + | WO => fun _ => left _ _ + | WS b _ x' => fun y => if bool_dec b (whd y) + then if weq _ x' (wtl y) then left _ _ else right _ _ + else right _ _ + end); clear weq. + + abstract (symmetry; apply shatter_word_0). + + abstract (subst; symmetry; apply (shatter_word y)). + + abstract (rewrite (shatter_word y); simpl; intro; injection H; intros; + eauto using inj_pair2_eq_dec, eq_nat_dec). + + abstract (rewrite (shatter_word y); simpl; intro; injection H; auto). +Defined. + +Fixpoint weqb sz (x : word sz) : word sz -> bool := + match x in word sz return word sz -> bool with + | WO => fun _ => true + | WS b _ x' => fun y => + if eqb b (whd y) + then if @weqb _ x' (wtl y) then true else false + else false + end. + +Theorem weqb_true_iff : forall sz x y, + @weqb sz x y = true <-> x = y. +Proof. + induction x; simpl; intros. + { split; auto. } + { rewrite (shatter_word y) in *. simpl in *. + case_eq (eqb b (whd y)); intros. + case_eq (weqb x (wtl y)); intros. + split; auto; intros. rewrite eqb_true_iff in H. f_equal; eauto. eapply IHx; eauto. + split; intros; try congruence. inversion H1; clear H1; subst. + eapply inj_pair2_eq_dec in H4. eapply IHx in H4. congruence. + eapply Peano_dec.eq_nat_dec. + split; intros; try congruence. + inversion H0. apply eqb_false_iff in H. congruence. } +Qed. + +(** * Combining and splitting *) + +Fixpoint combine (sz1 : nat) (w : word sz1) : forall sz2, word sz2 -> word (sz1 + sz2) := + match w in word sz1 return forall sz2, word sz2 -> word (sz1 + sz2) with + | WO => fun _ w' => w' + | WS b _ w' => fun _ w'' => WS b (combine w' w'') + end. + +Fixpoint split1 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz1 := + match sz1 with + | O => fun _ => WO + | S sz1' => fun w => WS (whd w) (split1 sz1' sz2 (wtl w)) + end. + +Fixpoint split2 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz2 := + match sz1 with + | O => fun w => w + | S sz1' => fun w => split2 sz1' sz2 (wtl w) + end. + +Ltac shatterer := simpl; intuition; + match goal with + | [ w : _ |- _ ] => rewrite (shatter_word w); simpl + end; f_equal; auto. + +Theorem combine_split : forall sz1 sz2 (w : word (sz1 + sz2)), + combine (split1 sz1 sz2 w) (split2 sz1 sz2 w) = w. + induction sz1; shatterer. +Qed. + +Theorem split1_combine : forall sz1 sz2 (w : word sz1) (z : word sz2), + split1 sz1 sz2 (combine w z) = w. + induction sz1; shatterer. +Qed. + +Theorem split2_combine : forall sz1 sz2 (w : word sz1) (z : word sz2), + split2 sz1 sz2 (combine w z) = z. + induction sz1; shatterer. +Qed. + +Require Import Coq.Logic.Eqdep_dec. + + +Theorem combine_assoc : forall n1 (w1 : word n1) n2 n3 (w2 : word n2) (w3 : word n3) Heq, + combine (combine w1 w2) w3 + = match Heq in _ = N return word N with + | refl_equal => combine w1 (combine w2 w3) + end. + induction w1; simpl; intuition. + + rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity. + + rewrite (IHw1 _ _ _ _ (plus_assoc _ _ _)); clear IHw1. + repeat match goal with + | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf + end. + generalize dependent (combine w1 (combine w2 w3)). + rewrite plus_assoc; intros. + rewrite (UIP_dec eq_nat_dec e (refl_equal _)). + rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)). + reflexivity. +Qed. + +Theorem split2_iter : forall n1 n2 n3 Heq w, + split2 n2 n3 (split2 n1 (n2 + n3) w) + = split2 (n1 + n2) n3 (match Heq in _ = N return word N with + | refl_equal => w + end). + induction n1; simpl; intuition. + + rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity. + + rewrite (IHn1 _ _ (plus_assoc _ _ _)). + f_equal. + repeat match goal with + | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf + end. + generalize dependent w. + simpl. + fold plus. + generalize (n1 + (n2 + n3)); clear. + intros. + generalize Heq e. + subst. + intros. + rewrite (UIP_dec eq_nat_dec e (refl_equal _)). + rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)). + reflexivity. +Qed. + +Theorem combine_end : forall n1 n2 n3 Heq w, + combine (split1 n2 n3 (split2 n1 (n2 + n3) w)) + (split2 (n1 + n2) n3 (match Heq in _ = N return word N with + | refl_equal => w + end)) + = split2 n1 (n2 + n3) w. + induction n1; simpl; intros. + + rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)). + apply combine_split. + + rewrite (shatter_word w) in *. + simpl. + eapply trans_eq; [ | apply IHn1 with (Heq := plus_assoc _ _ _) ]; clear IHn1. + repeat f_equal. + repeat match goal with + | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf + end. + simpl. + generalize dependent w. + rewrite plus_assoc. + intros. + rewrite (UIP_dec eq_nat_dec e (refl_equal _)). + rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)). + reflexivity. +Qed. + + +(** * Extension operators *) + +Definition sext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') := + if wmsb w false then + combine w (wones sz') + else + combine w (wzero sz'). + +Definition zext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') := + combine w (wzero sz'). + + +(** * Arithmetic *) + +Definition wneg sz (x : word sz) : word sz := + NToWord sz (Npow2 sz - wordToN x). + +Definition wordBin (f : N -> N -> N) sz (x y : word sz) : word sz := + NToWord sz (f (wordToN x) (wordToN y)). + +Definition wplus := wordBin Nplus. +Definition wmult := wordBin Nmult. +Definition wmult' sz (x y : word sz) : word sz := + split2 sz sz (NToWord (sz + sz) (Nmult (wordToN x) (wordToN y))). +Definition wminus sz (x y : word sz) : word sz := wplus x (wneg y). + +Definition wnegN sz (x : word sz) : word sz := + natToWord sz (pow2 sz - wordToNat x). + +Definition wordBinN (f : nat -> nat -> nat) sz (x y : word sz) : word sz := + natToWord sz (f (wordToNat x) (wordToNat y)). + +Definition wplusN := wordBinN plus. + +Definition wmultN := wordBinN mult. +Definition wmultN' sz (x y : word sz) : word sz := + split2 sz sz (natToWord (sz + sz) (mult (wordToNat x) (wordToNat y))). + +Definition wminusN sz (x y : word sz) : word sz := wplusN x (wnegN y). + +(** * Notations *) + +Delimit Scope word_scope with word. +Bind Scope word_scope with word. + +Notation "w ~ 1" := (WS true w) + (at level 7, left associativity, format "w '~' '1'") : word_scope. +Notation "w ~ 0" := (WS false w) + (at level 7, left associativity, format "w '~' '0'") : word_scope. + +Notation "^~" := wneg. +Notation "l ^+ r" := (@wplus _ l%word r%word) (at level 50, left associativity). +Notation "l ^* r" := (@wmult _ l%word r%word) (at level 40, left associativity). +Notation "l ^- r" := (@wminus _ l%word r%word) (at level 50, left associativity). + +Theorem wordToN_nat : forall sz (w : word sz), wordToN w = N_of_nat (wordToNat w). + induction w; intuition. + destruct b; unfold wordToN, wordToNat; fold wordToN; fold wordToNat. + + rewrite N_of_S. + rewrite N_of_mult. + rewrite <- IHw. + rewrite Nmult_comm. + reflexivity. + + rewrite N_of_mult. + rewrite <- IHw. + rewrite Nmult_comm. + reflexivity. +Qed. + +Theorem mod2_S : forall n k, + 2 * k = S n + -> mod2 n = true. + induction n using strong; intros. + destruct n; simpl in *. + elimtype False; omega. + destruct n; simpl in *; auto. + destruct k; simpl in *. + discriminate. + apply H with k; auto. +Qed. + +Theorem wzero'_def : forall sz, wzero' sz = wzero sz. + unfold wzero; induction sz; simpl; intuition. + congruence. +Qed. + +Theorem posToWord_nat : forall p sz, posToWord sz p = natToWord sz (nat_of_P p). + induction p; destruct sz; simpl; intuition; f_equal; try rewrite wzero'_def in *. + + rewrite ZL6. + destruct (ZL4 p) as [? Heq]; rewrite Heq; simpl. + replace (x + S x) with (S (2 * x)) by omega. + symmetry; apply mod2_S_double. + + rewrite IHp. + rewrite ZL6. + destruct (nat_of_P p); simpl; intuition. + replace (n + S n) with (S (2 * n)) by omega. + rewrite div2_S_double; auto. + + unfold nat_of_P; simpl. + rewrite ZL6. + replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega. + symmetry; apply mod2_double. + + rewrite IHp. + unfold nat_of_P; simpl. + rewrite ZL6. + replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega. + rewrite div2_double. + auto. + auto. +Qed. + +Theorem NToWord_nat : forall sz n, NToWord sz n = natToWord sz (nat_of_N n). + destruct n; simpl; intuition; try rewrite wzero'_def in *. + auto. + apply posToWord_nat. +Qed. + +Theorem wplus_alt : forall sz (x y : word sz), wplus x y = wplusN x y. + unfold wplusN, wplus, wordBinN, wordBin; intros. + + repeat rewrite wordToN_nat; repeat rewrite NToWord_nat. + rewrite nat_of_Nplus. + repeat rewrite nat_of_N_of_nat. + reflexivity. +Qed. + +Theorem wmult_alt : forall sz (x y : word sz), wmult x y = wmultN x y. + unfold wmultN, wmult, wordBinN, wordBin; intros. + + repeat rewrite wordToN_nat; repeat rewrite NToWord_nat. + rewrite nat_of_Nmult. + repeat rewrite nat_of_N_of_nat. + reflexivity. +Qed. + +Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n. + induction n; simpl; intuition. + rewrite <- IHn; clear IHn. + case_eq (Npow2 n); intuition. + rewrite untimes2. + replace (Npos p~0) with (Ndouble (Npos p)) by reflexivity. + apply nat_of_Ndouble. +Qed. + +Theorem wneg_alt : forall sz (x : word sz), wneg x = wnegN x. + unfold wnegN, wneg; intros. + repeat rewrite wordToN_nat; repeat rewrite NToWord_nat. + rewrite nat_of_Nminus. + do 2 f_equal. + apply Npow2_nat. + apply nat_of_N_of_nat. +Qed. + +Theorem wminus_Alt : forall sz (x y : word sz), wminus x y = wminusN x y. + intros; unfold wminusN, wminus; rewrite wneg_alt; apply wplus_alt. +Qed. + +Theorem wplus_unit : forall sz (x : word sz), natToWord sz 0 ^+ x = x. + intros; rewrite wplus_alt; unfold wplusN, wordBinN; intros. + rewrite roundTrip_0; apply natToWord_wordToNat. +Qed. + +Theorem wplus_comm : forall sz (x y : word sz), x ^+ y = y ^+ x. + intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; f_equal; auto. +Qed. + +Theorem drop_mod2 : forall n k, + 2 * k <= n + -> mod2 (n - 2 * k) = mod2 n. + induction n using strong; intros. + + do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition). + + destruct k; simpl in *; intuition. + + destruct k; simpl; intuition. + rewrite <- plus_n_Sm. + repeat rewrite untimes2 in *. + simpl; auto. + apply H; omega. +Qed. + +Theorem div2_minus_2 : forall n k, + 2 * k <= n + -> div2 (n - 2 * k) = div2 n - k. + induction n using strong; intros. + + do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *). + destruct k; simpl in *; intuition. + + destruct k; simpl in *; intuition. + rewrite <- plus_n_Sm. + apply H; omega. +Qed. + +Theorem div2_bound : forall k n, + 2 * k <= n + -> k <= div2 n. + intros; case_eq (mod2 n); intro Heq. + + rewrite (div2_odd _ Heq) in H. + omega. + + rewrite (div2_even _ Heq) in H. + omega. +Qed. + +Theorem drop_sub : forall sz n k, + k * pow2 sz <= n + -> natToWord sz (n - k * pow2 sz) = natToWord sz n. + induction sz; simpl; intuition; repeat rewrite untimes2 in *; f_equal. + + rewrite mult_assoc. + rewrite (mult_comm k). + rewrite <- mult_assoc. + apply drop_mod2. + rewrite mult_assoc. + rewrite (mult_comm 2). + rewrite <- mult_assoc. + auto. + + rewrite <- (IHsz (div2 n) k). + rewrite mult_assoc. + rewrite (mult_comm k). + rewrite <- mult_assoc. + rewrite div2_minus_2. + reflexivity. + rewrite mult_assoc. + rewrite (mult_comm 2). + rewrite <- mult_assoc. + auto. + + apply div2_bound. + rewrite mult_assoc. + rewrite (mult_comm 2). + rewrite <- mult_assoc. + auto. +Qed. + +Local Hint Extern 1 (_ <= _) => omega. + +Theorem wplus_assoc : forall sz (x y z : word sz), x ^+ (y ^+ z) = x ^+ y ^+ z. + intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; intros. + + repeat match goal with + | [ |- context[wordToNat (natToWord ?sz ?w)] ] => + let Heq := fresh "Heq" in + destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq + end. + + replace (wordToNat x + wordToNat y - x1 * pow2 sz + wordToNat z) + with (wordToNat x + wordToNat y + wordToNat z - x1 * pow2 sz) by auto. + replace (wordToNat x + (wordToNat y + wordToNat z - x0 * pow2 sz)) + with (wordToNat x + wordToNat y + wordToNat z - x0 * pow2 sz) by auto. + repeat rewrite drop_sub; auto. +Qed. + +Theorem roundTrip_1 : forall sz, wordToNat (natToWord (S sz) 1) = 1. + induction sz; simpl in *; intuition. +Qed. + +Theorem mod2_WS : forall sz (x : word sz) b, mod2 (wordToNat (WS b x)) = b. + intros. rewrite wordToNat_wordToNat'. + destruct b; simpl. + + rewrite untimes2. + case_eq (2 * wordToNat x); intuition. + eapply mod2_S; eauto. + rewrite <- (mod2_double (wordToNat x)); f_equal; omega. +Qed. + +Theorem div2_WS : forall sz (x : word sz) b, div2 (wordToNat (WS b x)) = wordToNat x. + destruct b; rewrite wordToNat_wordToNat'; unfold wordToNat'; fold wordToNat'. + apply div2_S_double. + apply div2_double. +Qed. + +Theorem wmult_unit : forall sz (x : word sz), natToWord sz 1 ^* x = x. + intros; rewrite wmult_alt; unfold wmultN, wordBinN; intros. + destruct sz; simpl. + rewrite (shatter_word x); reflexivity. + rewrite roundTrip_0; simpl. + rewrite plus_0_r. + rewrite (shatter_word x). + f_equal. + + apply mod2_WS. + + rewrite div2_WS. + apply natToWord_wordToNat. +Qed. + +Theorem wmult_comm : forall sz (x y : word sz), x ^* y = y ^* x. + intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; auto with arith. +Qed. + +Theorem wmult_assoc : forall sz (x y z : word sz), x ^* (y ^* z) = x ^* y ^* z. + intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; intros. + + repeat match goal with + | [ |- context[wordToNat (natToWord ?sz ?w)] ] => + let Heq := fresh "Heq" in + destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq + end. + + rewrite mult_minus_distr_l. + rewrite mult_minus_distr_r. + rewrite (mult_assoc (wordToNat x) x0). + rewrite <- (mult_assoc x1). + rewrite (mult_comm (pow2 sz)). + rewrite (mult_assoc x1). + repeat rewrite drop_sub; auto with arith. + rewrite (mult_comm x1). + rewrite <- (mult_assoc (wordToNat x)). + rewrite (mult_comm (wordToNat y)). + rewrite mult_assoc. + rewrite (mult_comm (wordToNat x)). + repeat rewrite <- mult_assoc. + auto with arith. + repeat rewrite <- mult_assoc. + auto with arith. +Qed. + +Theorem wmult_plus_distr : forall sz (x y z : word sz), (x ^+ y) ^* z = (x ^* z) ^+ (y ^* z). + intros; repeat rewrite wmult_alt; repeat rewrite wplus_alt; unfold wmultN, wplusN, wordBinN; intros. + + repeat match goal with + | [ |- context[wordToNat (natToWord ?sz ?w)] ] => + let Heq := fresh "Heq" in + destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq + end. + + rewrite mult_minus_distr_r. + rewrite <- (mult_assoc x0). + rewrite (mult_comm (pow2 sz)). + rewrite (mult_assoc x0). + + replace (wordToNat x * wordToNat z - x1 * pow2 sz + + (wordToNat y * wordToNat z - x2 * pow2 sz)) + with (wordToNat x * wordToNat z + wordToNat y * wordToNat z - x1 * pow2 sz - x2 * pow2 sz). + repeat rewrite drop_sub; auto with arith. + rewrite (mult_comm x0). + rewrite (mult_comm (wordToNat x + wordToNat y)). + rewrite <- (mult_assoc (wordToNat z)). + auto with arith. + generalize dependent (wordToNat x * wordToNat z). + generalize dependent (wordToNat y * wordToNat z). + intros. + omega. +Qed. + +Theorem wminus_def : forall sz (x y : word sz), x ^- y = x ^+ ^~ y. + reflexivity. +Qed. + +Theorem wordToNat_bound : forall sz (w : word sz), wordToNat w < pow2 sz. + induction w; simpl; intuition. + destruct b; simpl; omega. +Qed. + +Theorem natToWord_pow2 : forall sz, natToWord sz (pow2 sz) = natToWord sz 0. + induction sz; simpl; intuition. + + generalize (div2_double (pow2 sz)); simpl; intro Hr; rewrite Hr; clear Hr. + f_equal. + generalize (mod2_double (pow2 sz)); auto. + auto. +Qed. + +Theorem wminus_inv : forall sz (x : word sz), x ^+ ^~ x = wzero sz. + intros; rewrite wneg_alt; rewrite wplus_alt; unfold wnegN, wplusN, wzero, wordBinN; intros. + + repeat match goal with + | [ |- context[wordToNat (natToWord ?sz ?w)] ] => + let Heq := fresh "Heq" in + destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq + end. + + replace (wordToNat x + (pow2 sz - wordToNat x - x0 * pow2 sz)) + with (pow2 sz - x0 * pow2 sz). + rewrite drop_sub; auto with arith. + apply natToWord_pow2. + generalize (wordToNat_bound x). + omega. +Qed. + +Definition wring (sz : nat) : ring_theory (wzero sz) (wone sz) (@wplus sz) (@wmult sz) (@wminus sz) (@wneg sz) (@eq _) := + mk_rt _ _ _ _ _ _ _ + (@wplus_unit _) (@wplus_comm _) (@wplus_assoc _) + (@wmult_unit _) (@wmult_comm _) (@wmult_assoc _) + (@wmult_plus_distr _) (@wminus_def _) (@wminus_inv _). + +Theorem weqb_sound : forall sz (x y : word sz), weqb x y = true -> x = y. +Proof. + eapply weqb_true_iff. +Qed. + +Implicit Arguments weqb_sound []. + +Ltac isWcst w := + match eval hnf in w with + | WO => constr:(true) + | WS ?b ?w' => + match eval hnf in b with + | true => isWcst w' + | false => isWcst w' + | _ => constr:(false) + end + | _ => constr:(false) + end. + +Ltac wcst w := + let b := isWcst w in + match b with + | true => w + | _ => constr:(NotConstant) + end. + +(* Here's how you can add a ring for a specific bit-width. + There doesn't seem to be a polymorphic method, so this code really does need to be copied. *) + +(* +Definition wring8 := wring 8. +Add Ring wring8 : wring8 (decidable (weqb_sound 8), constants [wcst]). +*) + + +(** * Bitwise operators *) + +Fixpoint wnot sz (w : word sz) : word sz := + match w with + | WO => WO + | WS b _ w' => WS (negb b) (wnot w') + end. + +Fixpoint bitwp (f : bool -> bool -> bool) sz (w1 : word sz) : word sz -> word sz := + match w1 with + | WO => fun _ => WO + | WS b _ w1' => fun w2 => WS (f b (whd w2)) (bitwp f w1' (wtl w2)) + end. + +Definition wor := bitwp orb. +Definition wand := bitwp andb. +Definition wxor := bitwp xorb. + +Notation "l ^| r" := (@wor _ l%word r%word) (at level 50, left associativity). +Notation "l ^& r" := (@wand _ l%word r%word) (at level 40, left associativity). + +Theorem wor_unit : forall sz (x : word sz), wzero sz ^| x = x. + unfold wzero, wor; induction x; simpl; intuition congruence. +Qed. + +Theorem wor_comm : forall sz (x y : word sz), x ^| y = y ^| x. + unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool. +Qed. + +Theorem wor_assoc : forall sz (x y z : word sz), x ^| (y ^| z) = x ^| y ^| z. + unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool. +Qed. + +Theorem wand_unit : forall sz (x : word sz), wones sz ^& x = x. + unfold wand; induction x; simpl; intuition congruence. +Qed. + +Theorem wand_kill : forall sz (x : word sz), wzero sz ^& x = wzero sz. + unfold wzero, wand; induction x; simpl; intuition congruence. +Qed. + +Theorem wand_comm : forall sz (x y : word sz), x ^& y = y ^& x. + unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool. +Qed. + +Theorem wand_assoc : forall sz (x y z : word sz), x ^& (y ^& z) = x ^& y ^& z. + unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool. +Qed. + +Theorem wand_or_distr : forall sz (x y z : word sz), (x ^| y) ^& z = (x ^& z) ^| (y ^& z). + unfold wand, wor; induction x; intro y; rewrite (shatter_word y); intro z; rewrite (shatter_word z); simpl; intuition; f_equal; auto with bool. + destruct (whd y); destruct (whd z); destruct b; reflexivity. +Qed. + +Definition wbring (sz : nat) : semi_ring_theory (wzero sz) (wones sz) (@wor sz) (@wand sz) (@eq _) := + mk_srt _ _ _ _ _ + (@wor_unit _) (@wor_comm _) (@wor_assoc _) + (@wand_unit _) (@wand_kill _) (@wand_comm _) (@wand_assoc _) + (@wand_or_distr _). + + +(** * Inequality proofs *) + +Ltac word_simpl := unfold sext, zext, wzero in *; simpl in *. + +Ltac word_eq := ring. + +Ltac word_eq1 := match goal with + | _ => ring + | [ H : _ = _ |- _ ] => ring [H] + end. + +Theorem word_neq : forall sz (w1 w2 : word sz), + w1 ^- w2 <> wzero sz + -> w1 <> w2. + intros; intro; subst. + unfold wminus in H. + rewrite wminus_inv in H. + tauto. +Qed. + +Ltac word_neq := apply word_neq; let H := fresh "H" in intro H; simpl in H; ring_simplify in H; try discriminate. + +Ltac word_contra := match goal with + | [ H : _ <> _ |- False ] => apply H; ring + end. + +Ltac word_contra1 := match goal with + | [ H : _ <> _ |- False ] => apply H; + match goal with + | _ => ring + | [ H' : _ = _ |- _ ] => ring [H'] + end + end. + +Open Scope word_scope. + +(** * Signed Logic **) +Fixpoint wordToZ sz (w : word sz) : Z := + if wmsb w true then + (** Negative **) + match wordToN (wneg w) with + | N0 => 0%Z + | Npos x => Zneg x + end + else + (** Positive **) + match wordToN w with + | N0 => 0%Z + | Npos x => Zpos x + end. + +(** * Comparison Predicates and Deciders **) +Definition wlt sz (l r : word sz) : Prop := + Nlt (wordToN l) (wordToN r). +Definition wslt sz (l r : word sz) : Prop := + Zlt (wordToZ l) (wordToZ r). + +Notation "w1 > w2" := (@wlt _ w2%word w1%word) : word_scope. +Notation "w1 >= w2" := (~(@wlt _ w1%word w2%word)) : word_scope. +Notation "w1 < w2" := (@wlt _ w1%word w2%word) : word_scope. +Notation "w1 <= w2" := (~(@wlt _ w2%word w1%word)) : word_scope. + +Notation "w1 '>s' w2" := (@wslt _ w2%word w1%word) (at level 70) : word_scope. +Notation "w1 '>s=' w2" := (~(@wslt _ w1%word w2%word)) (at level 70) : word_scope. +Notation "w1 '<s' w2" := (@wslt _ w1%word w2%word) (at level 70) : word_scope. +Notation "w1 '<s=' w2" := (~(@wslt _ w2%word w1%word)) (at level 70) : word_scope. + +Definition wlt_dec : forall sz (l r : word sz), {l < r} + {l >= r}. + refine (fun sz l r => + match Ncompare (wordToN l) (wordToN r) as k return Ncompare (wordToN l) (wordToN r) = k -> _ with + | Lt => fun pf => left _ _ + | _ => fun pf => right _ _ + end (refl_equal _)); + abstract congruence. +Defined. + +Definition wslt_dec : forall sz (l r : word sz), {l <s r} + {l >s= r}. + refine (fun sz l r => + match Zcompare (wordToZ l) (wordToZ r) as c return Zcompare (wordToZ l) (wordToZ r) = c -> _ with + | Lt => fun pf => left _ _ + | _ => fun pf => right _ _ + end (refl_equal _)); + abstract congruence. +Defined. + +(* Ordering Lemmas **) +Lemma lt_le : forall sz (a b : word sz), + a < b -> a <= b. +Proof. + unfold wlt, Nlt. intros. intro. rewrite <- Ncompare_antisym in H0. rewrite H in H0. simpl in *. congruence. +Qed. +Lemma eq_le : forall sz (a b : word sz), + a = b -> a <= b. +Proof. + intros; subst. unfold wlt, Nlt. rewrite Ncompare_refl. congruence. +Qed. +Lemma wordToN_inj : forall sz (a b : word sz), + wordToN a = wordToN b -> a = b. +Proof. + induction a; intro b0; rewrite (shatter_word b0); intuition. + simpl in H. + destruct b; destruct (whd b0); intros. + f_equal. eapply IHa. eapply Nsucc_inj in H. + destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence. + destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H. + destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H. + f_equal. eapply IHa. + destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence. +Qed. +Lemma unique_inverse : forall sz (a b1 b2 : word sz), + a ^+ b1 = wzero _ -> + a ^+ b2 = wzero _ -> + b1 = b2. +Proof. + intros. + transitivity (b1 ^+ wzero _). + rewrite wplus_comm. rewrite wplus_unit. auto. + transitivity (b1 ^+ (a ^+ b2)). congruence. + rewrite wplus_assoc. + rewrite (wplus_comm b1). rewrite H. rewrite wplus_unit. auto. +Qed. +Lemma sub_0_eq : forall sz (a b : word sz), + a ^- b = wzero _ -> a = b. +Proof. + intros. destruct (weq (wneg b) (wneg a)). + transitivity (a ^+ (^~ b ^+ b)). + rewrite (wplus_comm (^~ b)). rewrite wminus_inv. + rewrite wplus_comm. rewrite wplus_unit. auto. + rewrite e. rewrite wplus_assoc. rewrite wminus_inv. rewrite wplus_unit. auto. + unfold wminus in H. + generalize (unique_inverse a (wneg a) (^~ b)). + intros. elimtype False. apply n. symmetry; apply H0. + apply wminus_inv. + auto. +Qed. + +Lemma le_neq_lt : forall sz (a b : word sz), + b <= a -> a <> b -> b < a. +Proof. + intros; destruct (wlt_dec b a); auto. + elimtype False. apply H0. unfold wlt, Nlt in *. + eapply wordToN_inj. eapply Ncompare_eq_correct. + case_eq ((wordToN a ?= wordToN b)%N); auto; try congruence. + intros. rewrite <- Ncompare_antisym in n. rewrite H1 in n. simpl in *. congruence. +Qed. + + +Hint Resolve word_neq lt_le eq_le sub_0_eq le_neq_lt : worder. + +Ltac shatter_word x := + match type of x with + | word 0 => try rewrite (shatter_word_0 x) in * + | word (S ?N) => + let x' := fresh in + let H := fresh in + destruct (@shatter_word_S N x) as [ ? [ x' H ] ]; + rewrite H in *; clear H; shatter_word x' + end. + + +(** Uniqueness of equality proofs **) +Lemma rewrite_weq : forall sz (a b : word sz) + (pf : a = b), + weq a b = left _ pf. +Proof. + intros; destruct (weq a b); try solve [ elimtype False; auto ]. + f_equal. + eapply UIP_dec. eapply weq. +Qed. + + +(** * Some more useful derived facts *) + +Lemma natToWord_plus : forall sz n m, natToWord sz (n + m) = natToWord _ n ^+ natToWord _ m. + destruct sz; intuition. + rewrite wplus_alt. + unfold wplusN, wordBinN. + destruct (wordToNat_natToWord (S sz) n); intuition. + destruct (wordToNat_natToWord (S sz) m); intuition. + rewrite H0; rewrite H2; clear H0 H2. + replace (n - x * pow2 (S sz) + (m - x0 * pow2 (S sz))) with (n + m - x * pow2 (S sz) - x0 * pow2 (S sz)) + by omega. + repeat rewrite drop_sub; auto; omega. +Qed. + +Lemma natToWord_S : forall sz n, natToWord sz (S n) = natToWord _ 1 ^+ natToWord _ n. + intros; change (S n) with (1 + n); apply natToWord_plus. +Qed. + +Theorem natToWord_inj : forall sz n m, natToWord sz n = natToWord sz m + -> (n < pow2 sz)%nat + -> (m < pow2 sz)%nat + -> n = m. + intros. + apply (f_equal (@wordToNat _)) in H. + destruct (wordToNat_natToWord sz n). + destruct (wordToNat_natToWord sz m). + intuition. + rewrite H4 in H; rewrite H2 in H; clear H4 H2. + assert (x = 0). + destruct x; auto. + simpl in *. + generalize dependent (x * pow2 sz). + intros. + omega. + assert (x0 = 0). + destruct x0; auto. + simpl in *. + generalize dependent (x0 * pow2 sz). + intros. + omega. + subst; simpl in *; omega. +Qed. + +Lemma wordToNat_natToWord_idempotent : forall sz n, + (N.of_nat n < Npow2 sz)%N + -> wordToNat (natToWord sz n) = n. + intros. + destruct (wordToNat_natToWord sz n); intuition. + destruct x. + simpl in *; omega. + simpl in *. + apply Nlt_out in H. + autorewrite with N in *. + rewrite Npow2_nat in *. + generalize dependent (x * pow2 sz). + intros; omega. +Qed. + +Lemma wplus_cancel : forall sz (a b c : word sz), + a ^+ c = b ^+ c + -> a = b. + intros. + apply (f_equal (fun x => x ^+ ^~ c)) in H. + repeat rewrite <- wplus_assoc in H. + rewrite wminus_inv in H. + repeat rewrite (wplus_comm _ (wzero sz)) in H. + repeat rewrite wplus_unit in H. + assumption. +Qed. @@ -1,12 +1,12 @@ -Synthesizing Correct-by-Construction Assembly for Cryptographic Primitives +[](https://travis-ci.org/mit-plv/fiat-crypto) + +Fiat-Crypto: Synthesizing Correct-by-Construction Assembly for Cryptographic Primitives ----- -... which would make a good paper title. +NOTE: The github.com repo is only intermittently synced with +github.mit.edu. To build: - git clone git@github.mit.edu:plv/bedrock.git - ( cd bedrock && make Bedrock/Word.vo ) - ( cd coqprime && make ) - export COQPATH="$(pwd)/bedrock:$(pwd)/coqprime${COQPATH:+:}$COQPATH" + export COQPATH="$(pwd)/coqprime${COQPATH:+:}$COQPATH" make diff --git a/_CoqProject b/_CoqProject index c92f9481c..567860b25 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,22 +1,21 @@ -R src Crypto --R Coqprime/Coqprime Coqprime +-R Bedrock Bedrock +Bedrock/Nomega.v +Bedrock/Word.v +src/Algebra.v src/BaseSystem.v src/BaseSystemProofs.v -src/EdDSAProofs.v -src/Rep.v src/Testbit.v src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v -src/CompleteEdwardsCurve/DoubleAndAdd.v src/CompleteEdwardsCurve/ExtendedCoordinates.v src/CompleteEdwardsCurve/Pre.v src/Encoding/EncodingTheorems.v src/Encoding/ModularWordEncodingPre.v src/Encoding/ModularWordEncodingTheorems.v -src/Encoding/PointEncodingPre.v -src/Encoding/PointEncodingTheorems.v +src/Experiments/DerivationsOptionRectLetInEncoding.v +src/Experiments/GenericFieldPow.v +src/Experiments/SpecEd25519.v src/ModularArithmetic/ExtendedBaseVector.v -src/ModularArithmetic/FField.v -src/ModularArithmetic/FNsatz.v src/ModularArithmetic/ModularArithmeticTheorems.v src/ModularArithmetic/ModularBaseSystem.v src/ModularArithmetic/ModularBaseSystemOpt.v @@ -28,15 +27,13 @@ src/ModularArithmetic/PseudoMersenneBaseParams.v src/ModularArithmetic/PseudoMersenneBaseRep.v src/ModularArithmetic/Tutorial.v src/Spec/CompleteEdwardsCurve.v -src/Spec/Ed25519.v src/Spec/EdDSA.v src/Spec/Encoding.v src/Spec/ModularArithmetic.v src/Spec/ModularWordEncoding.v -src/Spec/PointEncoding.v -src/Specific/Ed25519.v src/Specific/GF1305.v src/Specific/GF25519.v +src/Tactics/Nsatz.v src/Tactics/VerdiTactics.v src/Util/CaseUtil.v src/Util/IterAssocOp.v @@ -44,6 +41,7 @@ src/Util/ListUtil.v src/Util/NatUtil.v src/Util/NumTheoryUtil.v src/Util/Tactics.v +src/Util/Tuple.v src/Util/WordUtil.v src/Util/ZUtil.v src/Assembly/QhasmCommon.v diff --git a/coqprime-8.5/Coqprime/Cyclic.v b/coqprime-8.5/Coqprime/Cyclic.v new file mode 100644 index 000000000..c25f683ca --- /dev/null +++ b/coqprime-8.5/Coqprime/Cyclic.v @@ -0,0 +1,244 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + Cyclic.v + + Proof that an abelien ring is cyclic + ************************************************************************) +Require Import ZCAux. +Require Import List. +Require Import Root. +Require Import UList. +Require Import IGroup. +Require Import EGroup. +Require Import FGroup. + +Open Scope Z_scope. + +Section Cyclic. + +Variable A: Set. +Variable plus mult: A -> A -> A. +Variable op: A -> A. +Variable zero one: A. +Variable support: list A. +Variable e: A. + +Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}. +Hypothesis e_not_zero: zero <> e. +Hypothesis support_ulist: ulist support. +Hypothesis e_in_support: In e support. +Hypothesis zero_in_support: In zero support. +Hypothesis mult_internal: forall a b, In a support -> In b support -> In (mult a b) support. +Hypothesis mult_assoc: forall a b c, In a support -> In b support -> In c support -> mult a (mult b c) = mult (mult a b) c. +Hypothesis e_is_zero_l: forall a, In a support -> mult e a = a. +Hypothesis e_is_zero_r: forall a, In a support -> mult a e = a. +Hypothesis plus_internal: forall a b, In a support -> In b support -> In (plus a b) support. +Hypothesis plus_zero: forall a, In a support -> plus zero a = a. +Hypothesis plus_comm: forall a b, In a support -> In b support -> plus a b = plus b a. +Hypothesis plus_assoc: forall a b c, In a support -> In b support -> In c support -> plus a (plus b c) = plus (plus a b) c. +Hypothesis mult_zero: forall a, In a support -> mult zero a = zero. +Hypothesis mult_comm: forall a b, In a support -> In b support ->mult a b = mult b a. +Hypothesis mult_plus_distr: forall a b c, In a support -> In b support -> In c support -> mult a (plus b c) = plus (mult a b) (mult a c). +Hypothesis op_internal: forall a, In a support -> In (op a) support. +Hypothesis plus_op_zero: forall a, In a support -> plus a (op a) = zero. +Hypothesis mult_integral: forall a b, In a support -> In b support -> mult a b = zero -> a = zero \/ b = zero. + +Definition IA := (IGroup A mult support e A_dec support_ulist e_in_support mult_internal + mult_assoc + e_is_zero_l e_is_zero_r). + +Hint Resolve (fun x => isupport_incl _ mult support e A_dec x). + +Theorem gpow_evaln: forall n, 0 < n -> + exists p, (length p <= Zabs_nat n)%nat /\ (forall i, In i p -> In i support) /\ + forall x, In x IA.(s) -> eval A plus mult zero (zero::p) x = gpow x IA n. +intros n Hn; generalize Hn; pattern n; apply natlike_ind; auto with zarith. +intros H1; contradict H1; auto with zarith. +intros x Hx Rec _. +case Zle_lt_or_eq with (1 := Hx); clear Hx; intros Hx; subst; simpl. +case Rec; auto; simpl; intros p (Hp1, (Hp2, Hp3)); clear Rec. +exists (zero::p); split; simpl. +rewrite Zabs_nat_Zsucc; auto with arith zarith. +split. +intros i [Hi | Hi]; try rewrite <- Hi; auto. +intros x1 Hx1; simpl. +rewrite Hp3; repeat rewrite plus_zero; unfold Zsucc; try rewrite gpow_add; auto with zarith. +rewrite gpow_1; try apply mult_comm; auto. +apply (fun x => isupport_incl _ mult support e A_dec x); auto. +change (In (gpow x1 IA x) IA.(s)). +apply gpow_in; auto. +apply mult_internal; auto. +apply (fun x => isupport_incl _ mult support e A_dec x); auto. +change (In (gpow x1 IA x) IA.(s)). +apply gpow_in; auto. +exists (e:: nil); split; simpl. +compute; auto with arith. +split. +intros i [Hi | Hi]; try rewrite <- Hi; auto; case Hi. +intros x Hx; simpl. +rewrite plus_zero; rewrite (fun x => mult_comm x zero); try rewrite mult_zero; auto. +rewrite plus_comm; try rewrite plus_zero; auto. +Qed. + +Definition check_list_gpow: forall l n, (incl l IA.(s)) -> {forall a, In a l -> gpow a IA n = e} + {exists a, In a l /\ gpow a IA n <> e}. +intros l n; elim l; simpl; auto. +intros H; left; intros a H1; case H1. +intros a l1 Rec H. +case (A_dec (gpow a IA n) e); intros H2. +case Rec; try intros H3. +apply incl_tran with (2 := H); auto with datatypes. +left; intros a1 H4; case H4; auto. +intros H5; rewrite <- H5; auto. +right; case H3; clear H3; intros a1 (H3, H4). +exists a1; auto. +right; exists a; auto. +Defined. + + +Theorem prime_power_div: forall p q i, prime p -> 0 <= q -> 0 <= i -> (q | p ^ i) -> exists j, 0 <= j <= i /\ q = p ^ j. +intros p q i Hp Hq Hi H. +assert (Hp1: 0 < p). +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +pattern q; apply prime_div_induction with (p ^ i); auto with zarith. +exists 0; rewrite Zpower_0_r; auto with zarith. +intros p1 i1 Hp2 Hi1 H1. +case Zle_lt_or_eq with (1 := Hi1); clear Hi1; intros Hi1; subst. +assert (Heq: p1 = p). +apply prime_div_Zpower_prime with i; auto. +apply Zdivide_trans with (2 := H1). +apply Zpower_divide; auto with zarith. +exists i1; split; auto; try split; auto with zarith. +case (Zle_or_lt i1 i); auto; intros H2. +absurd (p1 ^ i1 <= p ^ i). +apply Zlt_not_le; rewrite Heq; apply Zpower_lt_monotone; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +apply Zdivide_le; auto with zarith. +rewrite Heq; auto. +exists 0; repeat rewrite Zpower_exp_0; auto with zarith. +intros p1 q1 Hpq (j1,((Hj1, Hj2), Hj3)) (j2, ((Hj4, Hj5), Hj6)). +case Zle_lt_or_eq with (1 := Hj1); clear Hj1; intros Hj1; subst. +case Zle_lt_or_eq with (1 := Hj4); clear Hj4; intros Hj4; subst. +inversion Hpq as [ H0 H1 H2]. +absurd (p | 1). +intros H3; absurd (1 < p). +apply Zle_not_lt; apply Zdivide_le; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +apply H2; apply Zpower_divide; auto with zarith. +exists j1; rewrite Zpower_0_r; auto with zarith. +exists j2; rewrite Zpower_0_r; auto with zarith. +Qed. + +Theorem inj_lt_inv: forall n m : nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat. +intros n m H; case (le_or_lt m n); auto; intros H1; contradict H. +apply Zle_not_lt; apply inj_le; auto. +Qed. + +Theorem not_all_solutions: forall i, 0 < i < g_order IA -> exists a, In a IA.(s) /\ gpow a IA i <> e. +intros i (Hi, Hi2). +case (check_list_gpow IA.(s) i); try intros H; auto with datatypes. +case (gpow_evaln i); auto; intros p (Hp1, (Hp2, Hp3)). +absurd ((op e) = zero). +intros H1; case e_not_zero. +rewrite <- (plus_op_zero e); try rewrite H1; auto. +rewrite plus_comm; auto. +apply (root_max_is_zero _ (fun x => In x support) plus mult op zero) with (l := IA.(s)) (p := op e :: p); auto with datatypes. +simpl; intros x [Hx | Hx]; try rewrite <- Hx; auto. +intros x Hx. +generalize (Hp3 _ Hx); simpl; rewrite plus_zero; auto. +intros tmp; rewrite tmp; clear tmp. +rewrite H; auto; rewrite plus_comm; auto with datatypes. +apply mult_internal; auto. +apply eval_P; auto. +simpl; apply lt_le_S; apply le_lt_trans with (1 := Hp1). +apply inj_lt_inv. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem divide_g_order_e_order: forall n, 0 <= n -> (n | g_order IA) -> exists a, In a IA.(s) /\ e_order A_dec a IA = n. +intros n Hn H. +assert (Hg: 0 < g_order IA). +apply g_order_pos. +assert (He: forall a, 0 <= e_order A_dec a IA). +intros a; apply Zlt_le_weak; apply e_order_pos. +pattern n; apply prime_div_induction with (n := g_order IA); auto. +exists e; split; auto. +apply IA.(e_in_s). +apply Zle_antisym. +apply Zdivide_le; auto with zarith. +apply e_order_divide_gpow; auto with zarith. +apply IA.(e_in_s). +rewrite gpow_1; auto. +apply IA.(e_in_s). +match goal with |- (_ <= ?X) => assert (0 < X) end; try apply e_order_pos; auto with zarith. +intros p i Hp Hi K. +assert (Hp1: 0 < p). +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +assert (Hi1: 0 < p ^ i). +apply Zpower_gt_0; auto. +case Zle_lt_or_eq with (1 := Hi); clear Hi; intros Hi; subst. +case (not_all_solutions (g_order IA / p)). +apply Zdivide_Zdiv_lt_pos; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +apply Zdivide_trans with (2 := K). +apply Zpower_divide; auto. +intros a (Ha1, Ha2). +exists (gpow a IA (g_order IA / p ^ i)); split. +apply gpow_in; auto. +match goal with |- ?X = ?Y => assert (H1: (X | Y) ) end; auto. +apply e_order_divide_gpow; auto with zarith. +apply gpow_in; auto. +rewrite <- gpow_gpow; auto with zarith. +rewrite Zmult_comm; rewrite <- Zdivide_Zdiv_eq; auto with zarith. +apply fermat_gen; auto. +apply Z_div_pos; auto with zarith. +case prime_power_div with (4 := H1); auto with zarith. +intros j ((Hj1, Hj2), Hj3). +case Zle_lt_or_eq with (1 := Hj2); intros Hj4; subst; auto. +case Ha2. +replace (g_order IA) with (((g_order IA / p ^i) * p ^ j) * p ^ (i - j - 1) * p). +rewrite Z_div_mult; auto with zarith. +repeat rewrite gpow_gpow; auto with zarith. +rewrite <- Hj3. +rewrite gpow_e_order_is_e; auto with zarith. +rewrite gpow_e; auto. +apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. +apply gpow_in; auto. +apply Z_div_pos; auto with zarith. +apply Zmult_le_0_compat; try apply Z_div_pos; auto with zarith. +pattern p at 4; rewrite <- Zpower_1_r. +repeat rewrite <- Zmult_assoc; repeat rewrite <- Zpower_exp; auto with zarith. +replace (j + (i - j - 1 + 1)) with i; auto with zarith. +apply sym_equal; rewrite Zmult_comm; apply Zdivide_Zdiv_eq; auto with zarith. +rewrite Zpower_0_r; exists e; split. +apply IA.(e_in_s). +match goal with |- ?X = 1 => assert (tmp: 0 < X); try apply e_order_pos; +case Zle_lt_or_eq with 1 X; auto with zarith; clear tmp; intros H1 end. +absurd (gpow IA.(FGroup.e) IA 1 = IA.(FGroup.e)). +apply gpow_e_order_lt_is_not_e with A_dec; auto with zarith. +apply gpow_e; auto with zarith. +intros p q H1 (a, (Ha1, Ha2)) (b, (Hb1, Hb2)). +exists (mult a b); split. +apply IA.(internal); auto. +rewrite <- Ha2; rewrite <- Hb2; apply order_mult; auto. +rewrite Ha2; rewrite Hb2; auto. +Qed. + +Set Implicit Arguments. +Definition cyclic (A: Set) A_dec (op: A -> A -> A) (G: FGroup op):= exists a, In a G.(s) /\ e_order A_dec a G = g_order G. +Unset Implicit Arguments. + +Theorem cyclic_field: cyclic A_dec IA. +red; apply divide_g_order_e_order; auto. +apply Zlt_le_weak; apply g_order_pos. +exists 1; ring. +Qed. + +End Cyclic. diff --git a/coqprime-8.5/Coqprime/EGroup.v b/coqprime-8.5/Coqprime/EGroup.v new file mode 100644 index 000000000..933176abd --- /dev/null +++ b/coqprime-8.5/Coqprime/EGroup.v @@ -0,0 +1,605 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + EGroup.v + + Given an element a, create the group {e, a, a^2, ..., a^n} + **********************************************************************) +Require Import ZArith. +Require Import Tactic. +Require Import List. +Require Import ZCAux. +Require Import ZArith Znumtheory. +Require Import Wf_nat. +Require Import UList. +Require Import FGroup. +Require Import Lagrange. + +Open Scope Z_scope. + +Section EGroup. + +Variable A: Set. + +Variable A_dec: forall a b: A, {a = b} + {~ a = b}. + +Variable op: A -> A -> A. + +Variable a: A. + +Variable G: FGroup op. + +Hypothesis a_in_G: In a G.(s). + + +(************************************** + The power function for the group + **************************************) + +Set Implicit Arguments. +Definition gpow n := match n with Zpos p => iter_pos _ (op a) G.(e) p | _ => G.(e) end. +Unset Implicit Arguments. + +Theorem gpow_0: gpow 0 = G.(e). +simpl; sauto. +Qed. + +Theorem gpow_1 : gpow 1 = a. +simpl; sauto. +Qed. + +(************************************** + Some properties of the power function + **************************************) + +Theorem gpow_in: forall n, In (gpow n) G.(s). +intros n; case n; simpl; auto. +intros p; apply iter_pos_invariant with (Inv := fun x => In x G.(s)); auto. +Qed. + +Theorem gpow_op: forall b p, In b G.(s) -> iter_pos _ (op a) b p = op (iter_pos _ (op a) G.(e) p) b. +intros b p; generalize b; elim p; simpl; auto; clear b p. +intros p Rec b Hb. +assert (H: In (gpow (Zpos p)) G.(s)). +apply gpow_in. +rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto. +repeat rewrite G.(assoc); auto. +intros p Rec b Hb. +assert (H: In (gpow (Zpos p)) G.(s)). +apply gpow_in. +rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto. +repeat rewrite G.(assoc); auto. +intros b H; rewrite e_is_zero_r; auto. +Qed. + +Theorem gpow_add: forall n m, 0 <= n -> 0 <= m -> gpow (n + m) = op (gpow n) (gpow m). +intros n; case n. +intros m _ _; simpl; apply sym_equal; apply e_is_zero_l; apply gpow_in. +2: intros p m H; contradict H; auto with zarith. +intros p1 m; case m. +intros _ _; simpl; apply sym_equal; apply e_is_zero_r. +exact (gpow_in (Zpos p1)). +2: intros p2 _ H; contradict H; auto with zarith. +intros p2 _ _; simpl. +rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos A x y p2)); auto. +exact (gpow_in (Zpos p2)). +Qed. + +Theorem gpow_1_more: + forall n, 0 < n -> gpow n = G.(e) -> forall m, 0 <= m -> exists p, 0 <= p < n /\ gpow m = gpow p. +intros n H1 H2 m Hm; generalize Hm; pattern m; apply Z_lt_induction; auto with zarith; clear m Hm. +intros m Rec Hm. +case (Zle_or_lt n m); intros H3. +case (Rec (m - n)); auto with zarith. +intros p (H4,H5); exists p; split; auto. +replace m with (n + (m - n)); auto with zarith. +rewrite gpow_add; try rewrite H2; try rewrite H5; sauto; auto with zarith. +generalize gpow_in; sauto. +exists m; auto. +Qed. + +Theorem gpow_i: forall n m, 0 <= n -> 0 <= m -> gpow n = gpow (n + m) -> gpow m = G.(e). +intros n m H1 H2 H3; generalize gpow_in; intro PI. +apply g_cancel_l with (g:= G) (a := gpow n); sauto. +rewrite <- gpow_add; try rewrite <- H3; sauto. +Qed. + +(************************************** + We build the support by iterating the power function + **************************************) + +Set Implicit Arguments. + +Fixpoint support_aux (b: A) (n: nat) {struct n}: list A := +b::let c := op a b in + match n with + O => nil | + (S n1) =>if A_dec c G.(e) then nil else support_aux c n1 + end. + +Definition support := support_aux G.(e) (Zabs_nat (g_order G)). + +Unset Implicit Arguments. + +(************************************** + Some properties of the support that helps to prove that we have a group + **************************************) + +Theorem support_aux_gpow: + forall n m b, 0 <= m -> In b (support_aux (gpow m) n) -> + exists p, (0 <= p < length (support_aux (gpow m) n))%nat /\ b = gpow (m + Z_of_nat p). +intros n; elim n; simpl. +intros n1 b Hm [H1 | H1]; exists 0%nat; simpl; rewrite Zplus_0_r; auto; case H1. +intros n1 Rec m b Hm [H1 | H1]. +exists 0%nat; simpl; rewrite Zplus_0_r; auto; auto with arith. +generalize H1; case (A_dec (op a (gpow m)) G.(e)); clear H1; simpl; intros H1 H2. +case H2. +case (Rec (1 + m) b); auto with zarith. +rewrite gpow_add; auto with zarith. +rewrite gpow_1; auto. +intros p (Hp1, Hp2); exists (S p); split; auto with zarith. +rewrite <- gpow_1. +rewrite <- gpow_add; auto with zarith. +rewrite inj_S; rewrite Hp2; eq_tac; auto with zarith. +Qed. + +Theorem gpow_support_aux_not_e: + forall n m p, 0 <= m -> m < p < m + Z_of_nat (length (support_aux (gpow m) n)) -> gpow p <> G.(e). +intros n; elim n; simpl. +intros m p Hm (H1, H2); contradict H2; auto with zarith. +intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl. +intros _ (H1, H2); contradict H2; auto with zarith. +assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p). +intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith. +rewrite tmp. +intros H1 (H2, H3); case (Zle_lt_or_eq (1 + m) p); auto with zarith; intros H4; subst. +apply (Rec (1 + m)); try split; auto with zarith. +rewrite gpow_add; auto with zarith. +rewrite gpow_1; auto with zarith. +rewrite gpow_add; try rewrite gpow_1; auto with zarith. +Qed. + +Theorem support_aux_not_e: forall n m b, 0 <= m -> In b (tail (support_aux (gpow m) n)) -> ~ b = G.(e). +intros n; elim n; simpl. +intros m b Hm H; case H. +intros n1 Rec m b Hm; case (A_dec (op a (gpow m)) G.(e)); intros H1 H2; simpl; auto. +assert (Hm1: 0 <= 1 + m); auto with zarith. +generalize( Rec (1 + m) b Hm1) H2; case n1; auto; clear Hm1. +intros _ [H3 | H3]; auto. +contradict H1; subst; auto. +rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith. +intros n2; case (A_dec (op a (op a (gpow m))) G.(e)); intros H3. +intros _ [H4 | H4]. +contradict H1; subst; auto. +case H4. +intros H4 [H5 | H5]; subst; auto. +Qed. + +Theorem support_aux_length_le: forall n a, (length (support_aux a n) <= n + 1)%nat. +intros n; elim n; simpl; auto. +intros n1 Rec a1; case (A_dec (op a a1) G.(e)); simpl; auto with arith. +Qed. + +Theorem support_aux_length_le_is_e: + forall n m, 0 <= m -> (length (support_aux (gpow m) n) <= n)%nat -> + gpow (m + Z_of_nat (length (support_aux (gpow m) n))) = G.(e) . +intros n; elim n; simpl; auto. +intros m _ H1; contradict H1; auto with arith. +intros n1 Rec m Hm; case (A_dec (op a (gpow m)) G.(e)); simpl; intros H1. +intros H2; rewrite Zplus_comm; rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith. +assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p). +intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith. +rewrite tmp; clear tmp. +rewrite <- gpow_1. +rewrite <- gpow_add; auto with zarith. +rewrite Zplus_assoc; rewrite (Zplus_comm 1); intros H2; apply Rec; auto with zarith. +Qed. + +Theorem support_aux_in: + forall n m p, 0 <= m -> (p < length (support_aux (gpow m) n))% nat -> + (In (gpow (m + Z_of_nat p)) (support_aux (gpow m) n)). +intros n; elim n; simpl; auto; clear n. +intros m p Hm H1; replace p with 0%nat. +left; eq_tac; auto with zarith. +generalize H1; case p; simpl; auto with arith. +intros n H2; contradict H2; apply le_not_lt; auto with arith. +intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl; intros H1 H2; auto. +replace p with 0%nat. +left; eq_tac; auto with zarith. +generalize H2; case p; simpl; auto with arith. +intros n H3; contradict H3; apply le_not_lt; auto with arith. +generalize H2; case p; simpl; clear H2. +rewrite Zplus_0_r; auto. +intros n. +assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p). +intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith. +rewrite tmp; clear tmp. +rewrite <- gpow_1; rewrite <- gpow_add; auto with zarith. +rewrite Zplus_assoc; rewrite (Zplus_comm 1); intros H2; right; apply Rec; auto with zarith. +Qed. + +Theorem support_aux_ulist: + forall n m, 0 <= m -> (forall p, 0 <= p < m -> gpow (1 + p) <> G.(e)) -> ulist (support_aux (gpow m) n). +intros n; elim n; auto; clear n. +intros m _ _; auto. +simpl; apply ulist_cons; auto. +intros n1 Rec m Hm H. +simpl; case (A_dec (op a (gpow m)) G.(e)); auto. +intros He; apply ulist_cons; auto. +intros H1; case (support_aux_gpow n1 (1 + m) (gpow m)); auto with zarith. +rewrite gpow_add; try rewrite gpow_1; auto with zarith. +intros p (Hp1, Hp2). +assert (H2: gpow (1 + Z_of_nat p) = G.(e)). +apply gpow_i with m; auto with zarith. +rewrite Hp2; eq_tac; auto with zarith. +case (Zle_or_lt m (Z_of_nat p)); intros H3; auto. +2: case (H (Z_of_nat p)); auto with zarith. +case (support_aux_not_e (S n1) m (gpow (1 + Z_of_nat p))); auto. +rewrite gpow_add; auto with zarith; simpl; rewrite e_is_zero_r; auto. +case (A_dec (op a (gpow m)) G.(e)); auto. +intros _; rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith. +replace (1 + Z_of_nat p) with ((1 + m) + (Z_of_nat (p - Zabs_nat m))); auto with zarith. +apply support_aux_in; auto with zarith. +rewrite inj_minus1; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply inj_le_rev. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith. +apply (Rec (1 + m)); auto with zarith. +intros p H1; case (Zle_lt_or_eq p m); intros; subst; auto with zarith. +rewrite gpow_add; auto with zarith. +rewrite gpow_1; auto. +Qed. + +Theorem support_gpow: forall b, (In b support) -> exists p, 0 <= p < Z_of_nat (length support) /\ b = gpow p. +intros b H; case (support_aux_gpow (Zabs_nat (g_order G)) 0 b); auto with zarith. +intros p ((H1, H2), H3); exists (Z_of_nat p); repeat split; auto with zarith. +apply inj_lt; auto. +Qed. + +Theorem support_incl_G: incl support G.(s). +intros a1 H; case (support_gpow a1); auto; intros p (H1, H2); subst; apply gpow_in. +Qed. + +Theorem gpow_support_not_e: forall p, 0 < p < Z_of_nat (length support) -> gpow p <> G.(e). +intros p (H1, H2); apply gpow_support_aux_not_e with (m := 0) (n := length G.(s)); simpl; + try split; auto with zarith. +rewrite <- (Zabs_nat_Z_of_nat (length G.(s))); auto. +Qed. + +Theorem support_not_e: forall b, In b (tail support) -> ~ b = G.(e). +intros b H; apply (support_aux_not_e (Zabs_nat (g_order G)) 0); auto with zarith. +Qed. + +Theorem support_ulist: ulist support. +apply (support_aux_ulist (Zabs_nat (g_order G)) 0); auto with zarith. +Qed. + +Theorem support_in_e: In G.(e) support. +unfold support; case (Zabs_nat (g_order G)); simpl; auto with zarith. +Qed. + +Theorem gpow_length_support_is_e: gpow (Z_of_nat (length support)) = G.(e). +apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith. +unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length. +rewrite <- (Zabs_nat_Z_of_nat (length G.(s))); auto. +exact support_ulist. +rewrite <- (Zabs_nat_Z_of_nat (length G.(s))); auto. +exact support_incl_G. +Qed. + +Theorem support_in: forall p, 0 <= p < Z_of_nat (length support) -> In (gpow p) support. +intros p (H, H1); unfold support. +rewrite <- (Zabs_eq p); auto with zarith. +rewrite <- (inj_Zabs_nat p); auto. +generalize (support_aux_in (Zabs_nat (g_order G)) 0); simpl; intros H2; apply H2; auto with zarith. +rewrite <- (fun x => Zabs_nat_Z_of_nat (@length A x)); auto. +apply Zabs_nat_lt; split; auto. +Qed. + +Theorem support_internal: forall a b, In a support -> In b support -> In (op a b) support. +intros a1 b1 H1 H2. +case support_gpow with (1 := H1); auto; intros p1 ((H3, H4), H5); subst. +case support_gpow with (1 := H2); auto; intros p2 ((H5, H6), H7); subst. +rewrite <- gpow_add; auto with zarith. +case gpow_1_more with (m:= p1 + p2) (2 := gpow_length_support_is_e); auto with zarith. +intros p3 ((H8, H9), H10); rewrite H10; apply support_in; auto with zarith. +Qed. + +Theorem support_i_internal: forall a, In a support -> In (G.(i) a) support. +generalize gpow_in; intros Hp. +intros a1 H1. +case support_gpow with (1 := H1); auto. +intros p1 ((H2, H3), H4); case Zle_lt_or_eq with (1 := H2); clear H2; intros H2; subst. +2: rewrite gpow_0; rewrite i_e; apply support_in_e. +replace (G.(i) (gpow p1)) with (gpow (Z_of_nat (length support - Zabs_nat p1))). +apply support_in; auto with zarith. +rewrite inj_minus1. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply inj_le_rev; rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply g_cancel_l with (g:= G) (a := gpow p1); sauto. +rewrite <- gpow_add; auto with zarith. +replace (p1 + Z_of_nat (length support - Zabs_nat p1)) with (Z_of_nat (length support)). +rewrite gpow_length_support_is_e; sauto. +rewrite inj_minus1; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply inj_le_rev; rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +Qed. + +(************************************** + We are now ready to build the group + **************************************) + +Definition Gsupport: (FGroup op). +generalize support_incl_G; unfold incl; intros Ho. +apply mkGroup with support G.(e) G.(i); sauto. +apply support_ulist. +apply support_internal. +intros a1 b1 c1 H1 H2 H3; apply G.(assoc); sauto. +apply support_in_e. +apply support_i_internal. +Defined. + +(************************************** + Definition of the order of an element + **************************************) +Set Implicit Arguments. + +Definition e_order := Z_of_nat (length support). + +Unset Implicit Arguments. + +(************************************** + Some properties of the order of an element + **************************************) + +Theorem gpow_e_order_is_e: gpow e_order = G.(e). +apply (support_aux_length_le_is_e (Zabs_nat (g_order G)) 0); simpl; auto with zarith. +unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length. +rewrite <- (Zabs_nat_Z_of_nat (length G.(s))); auto. +exact support_ulist. +rewrite <- (Zabs_nat_Z_of_nat (length G.(s))); auto. +exact support_incl_G. +Qed. + +Theorem gpow_e_order_lt_is_not_e: forall n, 1 <= n < e_order -> gpow n <> G.(e). +intros n (H1, H2); apply gpow_support_not_e; auto with zarith. +Qed. + +Theorem e_order_divide_g_order: (e_order | g_order G). +change ((g_order Gsupport) | g_order G). +apply lagrange; auto. +exact support_incl_G. +Qed. + +Theorem e_order_pos: 0 < e_order. +unfold e_order, support; case (Zabs_nat (g_order G)); simpl; auto with zarith. +Qed. + +Theorem e_order_divide_gpow: forall n, 0 <= n -> gpow n = G.(e) -> (e_order | n). +generalize gpow_in; intros Hp. +generalize e_order_pos; intros Hp1. +intros n Hn; generalize Hn; pattern n; apply Z_lt_induction; auto; clear n Hn. +intros n Rec Hn H. +case (Zle_or_lt e_order n); intros H1. +case (Rec (n - e_order)); auto with zarith. +apply g_cancel_l with (g:= G) (a := gpow e_order); sauto. +rewrite G.(e_is_zero_r); auto with zarith. +rewrite <- gpow_add; try (rewrite gpow_e_order_is_e; rewrite <- H; eq_tac); auto with zarith. +intros k Hk; exists (1 + k). +rewrite Zmult_plus_distr_l; rewrite <- Hk; auto with zarith. +case (Zle_lt_or_eq 0 n); auto with arith; intros H2; subst. +contradict H; apply support_not_e. +generalize H1; unfold e_order, support. +case (Zabs_nat (g_order G)); simpl; auto. +intros H3; contradict H3; auto with zarith. +intros n1; case (A_dec (op a G.(e)) G.(e)); simpl; intros _ H3. +contradict H3; auto with zarith. +generalize H3; clear H3. +assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p). +intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith. +rewrite tmp; clear tmp; intros H3. +change (In (gpow n) (support_aux (gpow 1) n1)). +replace n with (1 + Z_of_nat (Zabs_nat n - 1)). +apply support_aux_in; auto with zarith. +rewrite <- (fun x => Zabs_nat_Z_of_nat (@length A x)). +replace (Zabs_nat n - 1)%nat with (Zabs_nat (n - 1)). +apply Zabs_nat_lt; split; auto with zarith. +rewrite G.(e_is_zero_r) in H3; try rewrite gpow_1; auto with zarith. +apply inj_eq_rev; rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +rewrite inj_minus1; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply inj_le_rev; rewrite inj_Zabs_nat; simpl; auto with zarith. +rewrite Zabs_eq; auto with zarith. +rewrite inj_minus1; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +rewrite Zplus_comm; simpl; auto with zarith. +apply inj_le_rev; rewrite inj_Zabs_nat; simpl; auto with zarith. +rewrite Zabs_eq; auto with zarith. +exists 0; auto with arith. +Qed. + +End EGroup. + +Theorem gpow_gpow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op), + In a (s G) -> forall n m, 0 <= n -> 0 <= m -> gpow a G (n * m ) = gpow (gpow a G n) G m. +intros A op a G H n m; case n. +simpl; intros _ H1; generalize H1. +pattern m; apply natlike_ind; simpl; auto. +intros x H2 Rec _; unfold Zsucc; rewrite gpow_add; simpl; auto with zarith. +repeat rewrite G.(e_is_zero_r); auto with zarith. +apply gpow_in; sauto. +intros p1 _; case m; simpl; auto. +assert(H1: In (iter_pos A (op a) (e G) p1) (s G)). +refine (gpow_in _ _ _ _ _ (Zpos p1)); auto. +intros p2 _; pattern p2; apply Pind; simpl; auto. +rewrite Pmult_1_r; rewrite G.(e_is_zero_r); try rewrite G.(e_is_zero_r); auto. +intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l. +rewrite Pmult_1_r. +simpl; repeat rewrite iter_pos_plus; simpl. +rewrite G.(e_is_zero_r); auto. +rewrite gpow_op with (G:= G); try rewrite Rec; auto. +apply sym_equal; apply gpow_op; auto. +intros p Hp; contradict Hp; auto with zarith. +Qed. + +Theorem gpow_e: forall (A : Set) (op : A -> A -> A) (G : FGroup op) n, 0 <= n -> gpow G.(e) G n = G.(e). +intros A op G n; case n; simpl; auto with zarith. +intros p _; elim p; simpl; auto; intros p1 Rec; repeat rewrite Rec; auto. +Qed. + +Theorem gpow_pow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op), + In a (s G) -> forall n, 0 <= n -> gpow a G (2 ^ n) = G.(e) -> forall m, n <= m -> gpow a G (2 ^ m) = G.(e). +intros A op a G H n H1 H2 m Hm. +replace m with (n + (m - n)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +rewrite gpow_gpow; auto with zarith. +rewrite H2; apply gpow_e. +apply Zpower_ge_0; auto with zarith. +Qed. + +Theorem gpow_mult: forall (A : Set) (op : A -> A -> A) (a b: A) (G : FGroup op) + (comm: forall a b, In a (s G) -> In b (s G) -> op a b = op b a), + In a (s G) -> In b (s G) -> forall n, 0 <= n -> gpow (op a b) G n = op (gpow a G n) (gpow b G n). +intros A op a b G comm Ha Hb n; case n; simpl; auto. +intros _; rewrite G.(e_is_zero_r); auto. +2: intros p Hp; contradict Hp; auto with zarith. +intros p _; pattern p; apply Pind; simpl; auto. +repeat rewrite G.(e_is_zero_r); auto. +intros p3 Rec; rewrite Pplus_one_succ_r. +repeat rewrite iter_pos_plus; simpl. +repeat rewrite (fun x y H z => gpow_op A op x G H (op y z)) ; auto. +rewrite Rec. +repeat rewrite G.(e_is_zero_r); auto. +assert(H1: In (iter_pos A (op a) (e G) p3) (s G)). +refine (gpow_in _ _ _ _ _ (Zpos p3)); auto. +assert(H2: In (iter_pos A (op b) (e G) p3) (s G)). +refine (gpow_in _ _ _ _ _ (Zpos p3)); auto. +repeat rewrite <- G.(assoc); try eq_tac; auto. +rewrite (fun x y => comm (iter_pos A x y p3) b); auto. +rewrite (G.(assoc) a); try apply comm; auto. +Qed. + +Theorem Zdivide_mult_rel_prime: forall a b c : Z, (a | c) -> (b | c) -> rel_prime a b -> (a * b | c). +intros a b c (q1, H1) (q2, H2) H3. +assert (H4: (a | q2)). +apply Gauss with (2 := H3). +exists q1; rewrite <- H1; rewrite H2; auto with zarith. +case H4; intros q3 H5; exists q3; rewrite H2; rewrite H5; auto with zarith. +Qed. + +Theorem order_mult: forall (A : Set) (op : A -> A -> A) (A_dec: forall a b: A, {a = b} + {~ a = b}) (G : FGroup op) + (comm: forall a b, In a (s G) -> In b (s G) -> op a b = op b a) (a b: A), + In a (s G) -> In b (s G) -> rel_prime (e_order A_dec a G) (e_order A_dec b G) -> + e_order A_dec (op a b) G = e_order A_dec a G * e_order A_dec b G. +intros A op A_dec G comm a b Ha Hb Hab. +assert (Hoat: 0 < e_order A_dec a G); try apply e_order_pos. +assert (Hobt: 0 < e_order A_dec b G); try apply e_order_pos. +assert (Hoabt: 0 < e_order A_dec (op a b) G); try apply e_order_pos. +assert (Hoa: 0 <= e_order A_dec a G); auto with zarith. +assert (Hob: 0 <= e_order A_dec b G); auto with zarith. +apply Zle_antisym; apply Zdivide_le; auto with zarith. +apply Zmult_lt_O_compat; auto. +apply e_order_divide_gpow; sauto; auto with zarith. +rewrite gpow_mult; auto with zarith. +rewrite gpow_gpow; auto with zarith. +rewrite gpow_e_order_is_e; auto with zarith. +rewrite gpow_e; auto. +rewrite Zmult_comm. +rewrite gpow_gpow; auto with zarith. +rewrite gpow_e_order_is_e; auto with zarith. +rewrite gpow_e; auto. +apply Zdivide_mult_rel_prime; auto. +apply Gauss with (2 := Hab). +apply e_order_divide_gpow; auto with zarith. +rewrite <- (gpow_e _ _ G (e_order A_dec b G)); auto. +rewrite <- (gpow_e_order_is_e _ A_dec _ (op a b) G); auto with zarith. +rewrite <- gpow_gpow; auto with zarith. +rewrite (Zmult_comm (e_order A_dec (op a b) G)). +rewrite gpow_mult; auto with zarith. +rewrite gpow_gpow with (a := b); auto with zarith. +rewrite gpow_e_order_is_e; auto with zarith. +rewrite gpow_e; auto with zarith. +rewrite G.(e_is_zero_r); auto with zarith. +apply gpow_in; auto. +apply Gauss with (2 := rel_prime_sym _ _ Hab). +apply e_order_divide_gpow; auto with zarith. +rewrite <- (gpow_e _ _ G (e_order A_dec a G)); auto. +rewrite <- (gpow_e_order_is_e _ A_dec _ (op a b) G); auto with zarith. +rewrite <- gpow_gpow; auto with zarith. +rewrite (Zmult_comm (e_order A_dec (op a b) G)). +rewrite gpow_mult; auto with zarith. +rewrite gpow_gpow with (a := a); auto with zarith. +rewrite gpow_e_order_is_e; auto with zarith. +rewrite gpow_e; auto with zarith. +rewrite G.(e_is_zero_l); auto with zarith. +apply gpow_in; auto. +Qed. + +Theorem fermat_gen: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op), + In a G.(s) -> gpow a G (g_order G) = G.(e). +intros A A_dec op a G H. +assert (H1: (e_order A_dec a G | g_order G)). +apply e_order_divide_g_order; auto. +case H1; intros q; intros Hq; rewrite Hq. +assert (Hq1: 0 <= q). +apply Zmult_le_reg_r with (e_order A_dec a G); auto with zarith. +apply Zlt_gt; apply e_order_pos. +rewrite Zmult_0_l; rewrite <- Hq; apply Zlt_le_weak; apply g_order_pos. +rewrite Zmult_comm; rewrite gpow_gpow; auto with zarith. +rewrite gpow_e_order_is_e; auto with zarith. +apply gpow_e; auto. +apply Zlt_le_weak; apply e_order_pos. +Qed. + +Theorem order_div: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op) m, + 0 < m -> (forall p, prime p -> (p | m) -> gpow a G (m / p) <> G.(e)) -> + In a G.(s) -> gpow a G m = G.(e) -> e_order A_dec a G = m. +intros A Adec op a G m Hm H H1 H2. +assert (F1: 0 <= m); auto with zarith. +case (e_order_divide_gpow A Adec op a G H1 m F1 H2); intros q Hq. +assert (F2: 1 <= q). + case (Zle_or_lt 0 q); intros HH. + case (Zle_lt_or_eq _ _ HH); auto with zarith. + intros HH1; generalize Hm; rewrite Hq; rewrite <- HH1; + auto with zarith. + assert (F2: 0 <= (- q) * e_order Adec a G); auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + apply Zlt_le_weak; apply e_order_pos. + generalize F2; rewrite Zopp_mult_distr_l_reverse; + rewrite <- Hq; auto with zarith. +case (Zle_lt_or_eq _ _ F2); intros H3; subst; auto with zarith. +case (prime_dec q); intros Hq. + case (H q); auto with zarith. + rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith. + apply gpow_e_order_is_e; auto. +case (Zdivide_div_prime_le_square _ H3 Hq); intros r (Hr1, (Hr2, Hr3)). +case (H _ Hr1); auto. + apply Zdivide_trans with (1 := Hr2). + apply Zdivide_factor_r. +case Hr2; intros q1 Hq1; subst. +assert (F3: 0 < r). + generalize (prime_ge_2 _ Hr1); auto with zarith. +rewrite <- Zmult_assoc; rewrite Zmult_comm; rewrite <- Zmult_assoc; + rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith. +rewrite gpow_gpow; auto with zarith. + rewrite gpow_e_order_is_e; try rewrite gpow_e; auto. + apply Zmult_le_reg_r with r; auto with zarith. + apply Zlt_le_weak; apply e_order_pos. +apply Zmult_le_reg_r with r; auto with zarith. +Qed. diff --git a/coqprime-8.5/Coqprime/Euler.v b/coqprime-8.5/Coqprime/Euler.v new file mode 100644 index 000000000..06d92ce57 --- /dev/null +++ b/coqprime-8.5/Coqprime/Euler.v @@ -0,0 +1,88 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(************************************************************************ + + Definition of the Euler Totient function + +*************************************************************************) +Require Import ZArith. +Require Export Znumtheory. +Require Import Tactic. +Require Export ZSum. + +Open Scope Z_scope. + +Definition phi n := Zsum 1 (n - 1) (fun x => if rel_prime_dec x n then 1 else 0). + +Theorem phi_def_with_0: + forall n, 1< n -> phi n = Zsum 0 (n - 1) (fun x => if rel_prime_dec x n then 1 else 0). +intros n H; rewrite Zsum_S_left; auto with zarith. +case (rel_prime_dec 0 n); intros H2. +contradict H2; apply not_rel_prime_0; auto. +rewrite Zplus_0_l; auto. +Qed. + +Theorem phi_pos: forall n, 1 < n -> 0 < phi n. +intros n H; unfold phi. +case (Zle_lt_or_eq 2 n); auto with zarith; intros H1; subst. +rewrite Zsum_S_left; simpl; auto with zarith. +case (rel_prime_dec 1 n); intros H2. +apply Zlt_le_trans with (1 + 0); auto with zarith. +apply Zplus_le_compat_l. +pattern 0 at 1; replace 0 with ((1 + (n - 1) - 2) * 0); auto with zarith. +rewrite <- Zsum_c; auto with zarith. +apply Zsum_le; auto with zarith. +intros x H3; case (rel_prime_dec x n); auto with zarith. +case H2; apply rel_prime_1; auto with zarith. +rewrite Zsum_nn. +case (rel_prime_dec (2 - 1) 2); auto with zarith. +intros H1; contradict H1; apply rel_prime_1; auto with zarith. +Qed. + +Theorem phi_le_n_minus_1: forall n, 1 < n -> phi n <= n - 1. +intros n H; replace (n-1) with ((1 + (n - 1) - 1) * 1); auto with zarith. +rewrite <- Zsum_c; auto with zarith. +unfold phi; apply Zsum_le; auto with zarith. +intros x H1; case (rel_prime_dec x n); auto with zarith. +Qed. + +Theorem prime_phi_n_minus_1: forall n, prime n -> phi n = n - 1. +intros n H; replace (n-1) with ((1 + (n - 1) - 1) * 1); auto with zarith. +assert (Hu: 1 <= n - 1). +assert (2 <= n); auto with zarith. +apply prime_ge_2; auto. +rewrite <- Zsum_c; auto with zarith; unfold phi; apply Zsum_ext; auto. +intros x (H2, H3); case H; clear H; intros H H1. +generalize (H1 x); case (rel_prime_dec x n); auto with zarith. +intros H6 H7; contradict H6; apply H7; split; auto with zarith. +Qed. + +Theorem phi_n_minus_1_prime: forall n, 1 < n -> phi n = n - 1 -> prime n. +intros n H H1; case (prime_dec n); auto; intros H2. +assert (H3: phi n < n - 1); auto with zarith. +replace (n-1) with ((1 + (n - 1) - 1) * 1); auto with zarith. +assert (Hu: 1 <= n - 1); auto with zarith. +rewrite <- Zsum_c; auto with zarith; unfold phi; apply Zsum_lt; auto. +intros x _; case (rel_prime_dec x n); auto with zarith. +case not_prime_divide with n; auto. +intros x (H3, H4); exists x; repeat split; auto with zarith. +case (rel_prime_dec x n); auto with zarith. +intros H5; absurd (x = 1 \/ x = -1); auto with zarith. +case (Zis_gcd_unique x n x 1); auto. +apply Zis_gcd_intro; auto; exists 1; auto with zarith. +contradict H3; rewrite H1; auto with zarith. +Qed. + +Theorem phi_divide_prime: forall n, 1 < n -> (n - 1 | phi n) -> prime n. +intros n H1 H2; apply phi_n_minus_1_prime; auto. +apply Zle_antisym. +apply phi_le_n_minus_1; auto. +apply Zdivide_le; auto; auto with zarith. +apply phi_pos; auto. +Qed. diff --git a/coqprime-8.5/Coqprime/FGroup.v b/coqprime-8.5/Coqprime/FGroup.v new file mode 100644 index 000000000..a55710e7c --- /dev/null +++ b/coqprime-8.5/Coqprime/FGroup.v @@ -0,0 +1,123 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + FGroup.v + + Defintion and properties of finite groups + + Definition: FGroup + **********************************************************************) +Require Import List. +Require Import UList. +Require Import Tactic. +Require Import ZArith. + +Open Scope Z_scope. + +Set Implicit Arguments. + +(************************************** + A finite group is defined for an operation op + it has a support (s) + op operates inside the group (internal) + op is associative (assoc) + it has an element (e) that is neutral (e_is_zero_l e_is_zero_r) + it has an inverse operator (i) + the inverse operates inside the group (i_internal) + it gives an inverse (i_is_inverse_l is_is_inverse_r) + **************************************) + +Record FGroup (A: Set) (op: A -> A -> A): Set := mkGroup + {s : (list A); + unique_s: ulist s; + internal: forall a b, In a s -> In b s -> In (op a b) s; + assoc: forall a b c, In a s -> In b s -> In c s -> op a (op b c) = op (op a b) c; + e: A; + e_in_s: In e s; + e_is_zero_l: forall a, In a s -> op e a = a; + e_is_zero_r: forall a, In a s -> op a e = a; + i: A -> A; + i_internal: forall a, In a s -> In (i a) s; + i_is_inverse_l: forall a, (In a s) -> op (i a) a = e; + i_is_inverse_r: forall a, (In a s) -> op a (i a) = e +}. + +(************************************** + The order of a group is the lengh of the support + **************************************) + +Definition g_order (A: Set) (op: A -> A -> A) (g: FGroup op) := Z_of_nat (length g.(s)). + +Unset Implicit Arguments. + +Hint Resolve unique_s internal e_in_s e_is_zero_l e_is_zero_r i_internal + i_is_inverse_l i_is_inverse_r assoc. + + +Section FGroup. + +Variable A: Set. +Variable op: A -> A -> A. + +(************************************** + Some properties of a finite group + **************************************) + +Theorem g_cancel_l: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op a b = op a c -> b = c. +intros g a b c H1 H2 H3 H4; apply trans_equal with (op g.(e) b); sauto. +replace (g.(e)) with (op (g.(i) a) a); sauto. +apply trans_equal with (op (i g a) (op a b)); sauto. +apply sym_equal; apply assoc with g; auto. +rewrite H4. +apply trans_equal with (op (op (i g a) a) c); sauto. +apply assoc with g; auto. +replace (op (g.(i) a) a) with g.(e); sauto. +Qed. + +Theorem g_cancel_r: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op b a = op c a -> b = c. +intros g a b c H1 H2 H3 H4; apply trans_equal with (op b g.(e)); sauto. +replace (g.(e)) with (op a (g.(i) a)); sauto. +apply trans_equal with (op (op b a) (i g a)); sauto. +apply assoc with g; auto. +rewrite H4. +apply trans_equal with (op c (op a (i g a))); sauto. +apply sym_equal; apply assoc with g; sauto. +replace (op a (g.(i) a)) with g.(e); sauto. +Qed. + +Theorem e_unique: forall (g : FGroup op), forall e1, In e1 g.(s) -> (forall a, In a g.(s) -> op e1 a = a) -> e1 = g.(e). +intros g e1 He1 H2. +apply trans_equal with (op e1 g.(e)); sauto. +Qed. + +Theorem inv_op: forall (g: FGroup op) a b, In a g.(s) -> In b g.(s) -> g.(i) (op a b) = op (g.(i) b) (g.(i) a). +intros g a1 b1 H1 H2; apply g_cancel_l with (g := g) (a := op a1 b1); sauto. +repeat rewrite g.(assoc); sauto. +apply trans_equal with g.(e); sauto. +rewrite <- g.(assoc) with (a := a1); sauto. +rewrite g.(i_is_inverse_r); sauto. +rewrite g.(e_is_zero_r); sauto. +Qed. + +Theorem i_e: forall (g: FGroup op), g.(i) g.(e) = g.(e). +intro g; apply g_cancel_l with (g:= g) (a := g.(e)); sauto. +apply trans_equal with g.(e); sauto. +Qed. + +(************************************** + A group has at least one element + **************************************) + +Theorem g_order_pos: forall g: FGroup op, 0 < g_order g. +intro g; generalize g.(e_in_s); unfold g_order; case g.(s); simpl; auto with zarith. +Qed. + + + +End FGroup. diff --git a/coqprime-8.5/Coqprime/IGroup.v b/coqprime-8.5/Coqprime/IGroup.v new file mode 100644 index 000000000..11a73d414 --- /dev/null +++ b/coqprime-8.5/Coqprime/IGroup.v @@ -0,0 +1,253 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Igroup + + Build the group of the inversible elements for the operation + + Definition: ZpGroup + **********************************************************************) +Require Import ZArith. +Require Import Tactic. +Require Import Wf_nat. +Require Import UList. +Require Import ListAux. +Require Import FGroup. + +Open Scope Z_scope. + +Section IG. + +Variable A: Set. +Variable op: A -> A -> A. +Variable support: list A. +Variable e: A. + +Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}. +Hypothesis support_ulist: ulist support. +Hypothesis e_in_support: In e support. +Hypothesis op_internal: forall a b, In a support -> In b support -> In (op a b) support. +Hypothesis op_assoc: forall a b c, In a support -> In b support -> In c support -> op a (op b c) = op (op a b) c. +Hypothesis e_is_zero_l: forall a, In a support -> op e a = a. +Hypothesis e_is_zero_r: forall a, In a support -> op a e = a. + +(************************************** + is_inv_aux tests if there is an inverse of a for op in l + **************************************) + +Fixpoint is_inv_aux (l: list A) (a: A) {struct l}: bool := + match l with nil => false | cons b l1 => + if (A_dec (op a b) e) then if (A_dec (op b a) e) then true else is_inv_aux l1 a else is_inv_aux l1 a + end. + +Theorem is_inv_aux_false: forall b l, (forall a, (In a l) -> op b a <> e \/ op a b <> e) -> is_inv_aux l b = false. +intros b l; elim l; simpl; auto. +intros a l1 Rec H; case (A_dec (op a b) e); case (A_dec (op b a) e); auto. +intros H1 H2; case (H a); auto; intros H3; case H3; auto. +Qed. + +(************************************** + is_inv tests if there is an inverse in support + **************************************) +Definition is_inv := is_inv_aux support. + +(************************************** + isupport_aux returns the sublist of inversible element of support + **************************************) + +Fixpoint isupport_aux (l: list A) : list A := + match l with nil => nil | cons a l1 => if is_inv a then a::isupport_aux l1 else isupport_aux l1 end. + +(************************************** + Some properties of isupport_aux + **************************************) + +Theorem isupport_aux_is_inv_true: forall l a, In a (isupport_aux l) -> is_inv a = true. +intros l a; elim l; simpl; auto. +intros b l1 H; case_eq (is_inv b); intros H1; simpl; auto. +intros [H2 | H2]; subst; auto. +Qed. + +Theorem isupport_aux_is_in: forall l a, is_inv a = true -> In a l -> In a (isupport_aux l). +intros l a; elim l; simpl; auto. +intros b l1 Rec H [H1 | H1]; subst. +rewrite H; auto with datatypes. +case (is_inv b); auto with datatypes. +Qed. + + +Theorem isupport_aux_not_in: + forall b l, (forall a, (In a support) -> op b a <> e \/ op a b <> e) -> ~ In b (isupport_aux l). +intros b l; elim l; simpl; simpl; auto. +intros a l1 H; case_eq (is_inv a); intros H1; simpl; auto. +intros H2 [H3 | H3]; subst. +contradict H1. +unfold is_inv; rewrite is_inv_aux_false; auto. +case H; auto; apply isupport_aux_is_in; auto. +Qed. + +Theorem isupport_aux_incl: forall l, incl (isupport_aux l) l. +intros l; elim l; simpl; auto with datatypes. +intros a l1 H1; case (is_inv a); auto with datatypes. +Qed. + +Theorem isupport_aux_ulist: forall l, ulist l -> ulist (isupport_aux l). +intros l; elim l; simpl; auto with datatypes. +intros a l1 H1 H2; case_eq (is_inv a); intros H3; auto with datatypes. +apply ulist_cons; auto with datatypes. +intros H4; apply (ulist_app_inv _ (a::nil) l1 a); auto with datatypes. +apply (isupport_aux_incl l1 a); auto. +apply H1; apply ulist_app_inv_r with (a:: nil); auto. +apply H1; apply ulist_app_inv_r with (a:: nil); auto. +Qed. + +(************************************** + isupport is the sublist of inversible element of support + **************************************) + +Definition isupport := isupport_aux support. + +(************************************** + Some properties of isupport + **************************************) + +Theorem isupport_is_inv_true: forall a, In a isupport -> is_inv a = true. +unfold isupport; intros a H; apply isupport_aux_is_inv_true with (1 := H). +Qed. + +Theorem isupport_is_in: forall a, is_inv a = true -> In a support -> In a isupport. +intros a H H1; unfold isupport; apply isupport_aux_is_in; auto. +Qed. + +Theorem isupport_incl: incl isupport support. +unfold isupport; apply isupport_aux_incl. +Qed. + +Theorem isupport_ulist: ulist isupport. +unfold isupport; apply isupport_aux_ulist. +apply support_ulist. +Qed. + +Theorem isupport_length: (length isupport <= length support)%nat. +apply ulist_incl_length. +apply isupport_ulist. +apply isupport_incl. +Qed. + +Theorem isupport_length_strict: + forall b, (In b support) -> (forall a, (In a support) -> op b a <> e \/ op a b <> e) -> + (length isupport < length support)%nat. +intros b H H1; apply ulist_incl_length_strict. +apply isupport_ulist. +apply isupport_incl. +intros H2; case (isupport_aux_not_in b support); auto. +Qed. + +Fixpoint inv_aux (l: list A) (a: A) {struct l}: A := + match l with nil => e | cons b l1 => + if A_dec (op a b) e then if (A_dec (op b a) e) then b else inv_aux l1 a else inv_aux l1 a + end. + +Theorem inv_aux_prop_r: forall l a, is_inv_aux l a = true -> op a (inv_aux l a) = e. +intros l a; elim l; simpl. +intros; discriminate. +intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto. +Qed. + +Theorem inv_aux_prop_l: forall l a, is_inv_aux l a = true -> op (inv_aux l a) a = e. +intros l a; elim l; simpl. +intros; discriminate. +intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto. +Qed. + +Theorem inv_aux_inv: forall l a b, op a b = e -> op b a = e -> (In a l) -> is_inv_aux l b = true. +intros l a b; elim l; simpl. +intros _ _ H; case H. +intros c l1 Rec H H0 H1; case H1; clear H1; intros H1; subst; rewrite H. +case (A_dec (op b a) e); case (A_dec e e); auto. +intros H1 H2; contradict H2; rewrite H0; auto. +case (A_dec (op b c) e); case (A_dec (op c b) e); auto. +Qed. + +Theorem inv_aux_in: forall l a, In (inv_aux l a) l \/ inv_aux l a = e. +intros l a; elim l; simpl; auto. +intros b l1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros _ _ [H1 | H1]; auto. +Qed. + +(************************************** + The inverse function + **************************************) + +Definition inv := inv_aux support. + +(************************************** + Some properties of inv + **************************************) + +Theorem inv_prop_r: forall a, In a isupport -> op a (inv a) = e. +intros a H; unfold inv; apply inv_aux_prop_r with (l := support). +change (is_inv a = true). +apply isupport_is_inv_true; auto. +Qed. + +Theorem inv_prop_l: forall a, In a isupport -> op (inv a) a = e. +intros a H; unfold inv; apply inv_aux_prop_l with (l := support). +change (is_inv a = true). +apply isupport_is_inv_true; auto. +Qed. + +Theorem is_inv_true: forall a b, op b a = e -> op a b = e -> (In a support) -> is_inv b = true. +intros a b H H1 H2; unfold is_inv; apply inv_aux_inv with a; auto. +Qed. + +Theorem is_inv_false: forall b, (forall a, (In a support) -> op b a <> e \/ op a b <> e) -> is_inv b = false. +intros b H; unfold is_inv; apply is_inv_aux_false; auto. +Qed. + +Theorem inv_internal: forall a, In a isupport -> In (inv a) isupport. +intros a H; apply isupport_is_in. +apply is_inv_true with a; auto. +apply inv_prop_l; auto. +apply inv_prop_r; auto. +apply (isupport_incl a); auto. +case (inv_aux_in support a); unfold inv; auto. +intros H1; rewrite H1; apply e_in_support; auto with zarith. +Qed. + +(************************************** + We are now ready to build our group + **************************************) + +Definition IGroup : (FGroup op). +generalize (fun x=> (isupport_incl x)); intros Hx. +apply mkGroup with (s := isupport) (e := e) (i := inv); auto. +apply isupport_ulist. +intros a b H H1. +assert (Haii: In (inv a) isupport); try apply inv_internal; auto. +assert (Hbii: In (inv b) isupport); try apply inv_internal; auto. +apply isupport_is_in; auto. +apply is_inv_true with (op (inv b) (inv a)); auto. +rewrite op_assoc; auto. +rewrite <- (op_assoc a); auto. +rewrite inv_prop_r; auto. +rewrite e_is_zero_r; auto. +apply inv_prop_r; auto. +rewrite <- (op_assoc (inv b)); auto. +rewrite (op_assoc (inv a)); auto. +rewrite inv_prop_l; auto. +rewrite e_is_zero_l; auto. +apply inv_prop_l; auto. +apply isupport_is_in; auto. +apply is_inv_true with e; auto. +intros a H; apply inv_internal; auto. +intros; apply inv_prop_l; auto. +intros; apply inv_prop_r; auto. +Defined. + +End IG. diff --git a/coqprime-8.5/Coqprime/Iterator.v b/coqprime-8.5/Coqprime/Iterator.v new file mode 100644 index 000000000..96d3e5655 --- /dev/null +++ b/coqprime-8.5/Coqprime/Iterator.v @@ -0,0 +1,180 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export List. +Require Export Permutation. +Require Import Arith. + +Section Iterator. +Variables A B : Set. +Variable zero : B. +Variable f : A -> B. +Variable g : B -> B -> B. +Hypothesis g_zero : forall a, g a zero = a. +Hypothesis g_trans : forall a b c, g a (g b c) = g (g a b) c. +Hypothesis g_sym : forall a b, g a b = g b a. + +Definition iter := fold_right (fun a r => g (f a) r) zero. +Hint Unfold iter . + +Theorem iter_app: forall l1 l2, iter (app l1 l2) = g (iter l1) (iter l2). +intros l1; elim l1; simpl; auto. +intros l2; rewrite g_sym; auto. +intros a l H l2; rewrite H. +rewrite g_trans; auto. +Qed. + +Theorem iter_permutation: forall l1 l2, permutation l1 l2 -> iter l1 = iter l2. +intros l1 l2 H; elim H; simpl; auto; clear H l1 l2. +intros a l1 l2 H1 H2; apply f_equal2 with ( f := g ); auto. +intros a b l; (repeat rewrite g_trans). +apply f_equal2 with ( f := g ); auto. +intros l1 l2 l3 H H0 H1 H2; apply trans_equal with ( 1 := H0 ); auto. +Qed. + +Lemma iter_inv: + forall P l, + P zero -> + (forall a b, P a -> P b -> P (g a b)) -> + (forall x, In x l -> P (f x)) -> P (iter l). +intros P l H H0; (elim l; simpl; auto). +Qed. +Variable next : A -> A. + +Fixpoint progression (m : A) (n : nat) {struct n} : list A := + match n with 0 => nil + | S n1 => cons m (progression (next m) n1) end. + +Fixpoint next_n (c : A) (n : nat) {struct n} : A := + match n with 0 => c | S n1 => next_n (next c) n1 end. + +Theorem progression_app: + forall a b n m, + le m n -> + b = next_n a m -> + progression a n = app (progression a m) (progression b (n - m)). +intros a b n m; generalize a b n; clear a b n; elim m; clear m; simpl. +intros a b n H H0; apply f_equal2 with ( f := progression ); auto with arith. +intros m H a b n; case n; simpl; clear n. +intros H1; absurd (0 < 1 + m); auto with arith. +intros n H0 H1; apply f_equal2 with ( f := @cons A ); auto with arith. +Qed. + +Let iter_progression := fun m n => iter (progression m n). + +Theorem iter_progression_app: + forall a b n m, + le m n -> + b = next_n a m -> + iter (progression a n) = + g (iter (progression a m)) (iter (progression b (n - m))). +intros a b n m H H0; unfold iter_progression; rewrite (progression_app a b n m); + (try apply iter_app); auto. +Qed. + +Theorem length_progression: forall z n, length (progression z n) = n. +intros z n; generalize z; elim n; simpl; auto. +Qed. + +End Iterator. +Implicit Arguments iter [A B]. +Implicit Arguments progression [A]. +Implicit Arguments next_n [A]. +Hint Unfold iter . +Hint Unfold progression . +Hint Unfold next_n . + +Theorem iter_ext: + forall (A B : Set) zero (f1 : A -> B) f2 g l, + (forall a, In a l -> f1 a = f2 a) -> iter zero f1 g l = iter zero f2 g l. +intros A B zero f1 f2 g l; elim l; simpl; auto. +intros a l0 H H0; apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_map: + forall (A B C : Set) zero (f : B -> C) g (k : A -> B) l, + iter zero f g (map k l) = iter zero (fun x => f (k x)) g l. +intros A B C zero f g k l; elim l; simpl; auto. +intros; apply f_equal2 with ( f := g ); auto with arith. +Qed. + +Theorem iter_comp: + forall (A B : Set) zero (f1 f2 : A -> B) g l, + (forall a, g a zero = a) -> + (forall a b c, g a (g b c) = g (g a b) c) -> + (forall a b, g a b = g b a) -> + g (iter zero f1 g l) (iter zero f2 g l) = + iter zero (fun x => g (f1 x) (f2 x)) g l. +intros A B zero f1 f2 g l g_zero g_trans g_sym; elim l; simpl; auto. +intros a l0 H; rewrite <- H; (repeat rewrite <- g_trans). +apply f_equal2 with ( f := g ); auto. +(repeat rewrite g_trans); apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_com: + forall (A B : Set) zero (f : A -> A -> B) g l1 l2, + (forall a, g a zero = a) -> + (forall a b c, g a (g b c) = g (g a b) c) -> + (forall a b, g a b = g b a) -> + iter zero (fun x => iter zero (fun y => f x y) g l1) g l2 = + iter zero (fun y => iter zero (fun x => f x y) g l2) g l1. +intros A B zero f g l1 l2 H H0 H1; generalize l2; elim l1; simpl; auto; + clear l1 l2. +intros l2; elim l2; simpl; auto with arith. +intros; rewrite H1; rewrite H; auto with arith. +intros a l1 H2 l2; case l2; clear l2; simpl; auto. +elim l1; simpl; auto with arith. +intros; rewrite H1; rewrite H; auto with arith. +intros b l2. +rewrite <- (iter_comp + _ _ zero (fun x => f x a) + (fun x => iter zero (fun (y : A) => f x y) g l1)); auto with arith. +rewrite <- (iter_comp + _ _ zero (fun y => f b y) + (fun y => iter zero (fun (x : A) => f x y) g l2)); auto with arith. +(repeat rewrite H0); auto. +apply f_equal2 with ( f := g ); auto. +(repeat rewrite <- H0); auto. +apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_comp_const: + forall (A B : Set) zero (f : A -> B) g k l, + k zero = zero -> + (forall a b, k (g a b) = g (k a) (k b)) -> + k (iter zero f g l) = iter zero (fun x => k (f x)) g l. +intros A B zero f g k l H H0; elim l; simpl; auto. +intros a l0 H1; rewrite H0; apply f_equal2 with ( f := g ); auto. +Qed. + +Lemma next_n_S: forall n m, next_n S n m = plus n m. +intros n m; generalize n; elim m; clear n m; simpl; auto with arith. +intros m H n; case n; simpl; auto with arith. +rewrite H; auto with arith. +intros n1; rewrite H; simpl; auto with arith. +Qed. + +Theorem progression_S_le_init: + forall n m p, In p (progression S n m) -> le n p. +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with arith. +subst n; auto. +apply le_S_n; auto with arith. +Qed. + +Theorem progression_S_le_end: + forall n m p, In p (progression S n m) -> lt p (n + m). +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with arith. +subst n; auto with arith. +rewrite <- plus_n_Sm; auto with arith. +rewrite <- plus_n_Sm; auto with arith. +generalize (H (S n) p); auto with arith. +Qed. diff --git a/coqprime-8.5/Coqprime/Lagrange.v b/coqprime-8.5/Coqprime/Lagrange.v new file mode 100644 index 000000000..b35460bad --- /dev/null +++ b/coqprime-8.5/Coqprime/Lagrange.v @@ -0,0 +1,179 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Lagrange.v + + Proof of Lagrange theorem: + the oder of a subgroup divides the order of a group + + Definition: lagrange + **********************************************************************) +Require Import List. +Require Import UList. +Require Import ListAux. +Require Import ZArith Znumtheory. +Require Import NatAux. +Require Import FGroup. + +Open Scope Z_scope. + +Section Lagrange. + +Variable A: Set. + +Variable A_dec: forall a b: A, {a = b} + {~ a = b}. + +Variable op: A -> A -> A. + +Variable G: (FGroup op). + +Variable H:(FGroup op). + +Hypothesis G_in_H: (incl G.(s) H.(s)). + +(************************************** + A group and a subgroup have the same neutral element + **************************************) + +Theorem same_e_for_H_and_G: H.(e) = G.(e). +apply trans_equal with (op H.(e) H.(e)); sauto. +apply trans_equal with (op H.(e) (op G.(e) (H.(i) G.(e)))); sauto. +eq_tac; sauto. +apply trans_equal with (op G.(e) (op G.(e) (H.(i) G.(e)))); sauto. +repeat rewrite H.(assoc); sauto. +eq_tac; sauto. +apply trans_equal with G.(e); sauto. +apply trans_equal with (op G.(e) H.(e)); sauto. +eq_tac; sauto. +Qed. + +(************************************** + The proof works like this. + If G = {e, g1, g2, g3, .., gn} and {e, h1, h2, h3, ..., hm} + we construct the list mkGH + {e, g1, g2, g3, ...., gn + hi*e, hi * g1, hi * g2, ..., hi * gn if hi does not appear before + .... + hk*e, hk * g1, hk * g2, ..., hk * gn if hk does not appear before + } + that contains all the element of H. + We show that this list does not contain double (ulist). + **************************************) + +Fixpoint mkList (base l: (list A)) { struct l} : (list A) := + match l with + nil => nil + | cons a l1 => let r1 := mkList base l1 in + if (In_dec A_dec a r1) then r1 else + (map (op a) base) ++ r1 + end. + +Definition mkGH := mkList G.(s) H.(s). + +Theorem mkGH_length: divide (length G.(s)) (length mkGH). +unfold mkGH; elim H.(s); simpl. +exists 0%nat; auto with arith. +intros a l1 (c, H1); case (In_dec A_dec a (mkList G.(s) l1)); intros H2. +exists c; auto. +exists (1 + c)%nat; rewrite ListAux.length_app; rewrite ListAux.length_map; rewrite H1; ring. +Qed. + +Theorem mkGH_incl: incl H.(s) mkGH. +assert (H1: forall l, incl l H.(s) -> incl l (mkList G.(s) l)). +intros l; elim l; simpl; auto with datatypes. +intros a l1 H1 H2. +case (In_dec A_dec a (mkList (s G) l1)); auto with datatypes. +intros H3; assert (H4: incl l1 (mkList (s G) l1)). +apply H1; auto with datatypes. +intros b H4; apply H2; auto with datatypes. +intros b; simpl; intros [H5 | H5]; subst; auto. +intros _ b; simpl; intros [H3 | H3]; subst; auto. +apply in_or_app; left. +cut (In H.(e) G.(s)). +elim (s G); simpl; auto. +intros c l2 Hl2 [H3 | H3]; subst; sauto. +assert (In b H.(s)); sauto. +apply (H2 b); auto with datatypes. +rewrite same_e_for_H_and_G; sauto. +apply in_or_app; right. +apply H1; auto with datatypes. +apply incl_tran with (2:= H2); auto with datatypes. +unfold mkGH; apply H1; auto with datatypes. +Qed. + +Theorem incl_mkGH: incl mkGH H.(s). +assert (H1: forall l, incl l H.(s) -> incl (mkList G.(s) l) H.(s)). +intros l; elim l; simpl; auto with datatypes. +intros a l1 H1 H2. +case (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes. +apply H1; apply incl_tran with (2 := H2); auto with datatypes. +apply incl_app. +intros b H4. +case ListAux.in_map_inv with (1:= H4); auto. +intros c (Hc1, Hc2); subst; sauto. +apply internal; auto with datatypes. +apply H1; apply incl_tran with (2 := H2); auto with datatypes. +unfold mkGH; apply H1; auto with datatypes. +Qed. + +Theorem ulist_mkGH: ulist mkGH. +assert (H1: forall l, incl l H.(s) -> ulist (mkList G.(s) l)). +intros l; elim l; simpl; auto with datatypes. +intros a l1 H1 H2. +case (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes. +apply H1; apply incl_tran with (2 := H2); auto with datatypes. +apply ulist_app; auto. +apply ulist_map; sauto. +intros x y H4 H5 H6; apply g_cancel_l with (g:= H) (a := a); sauto. +apply H2; auto with datatypes. +apply H1; apply incl_tran with (2 := H2); auto with datatypes. +intros b H4 H5. +case ListAux.in_map_inv with (1:= H4); auto. +intros c (Hc, Hc1); subst. +assert (H6: forall l a b, In b G.(s) -> incl l H.(s) -> In a (mkList G.(s) l) -> In (op a b) (mkList G.(s) l)). +intros ll u v; elim ll; simpl; auto with datatypes. +intros w ll1 T0 T1 T2. +case (In_dec A_dec w (mkList (s G) ll1)); intros T3 T4; auto with datatypes. +apply T0; auto; apply incl_tran with (2:= T2); auto with datatypes. +case in_app_or with (1 := T4); intros T5; auto with datatypes. +apply in_or_app; left. +case ListAux.in_map_inv with (1:= T5); auto. +intros z (Hz1, Hz2); subst. +replace (op (op w z) v) with (op w (op z v)); sauto. +apply in_map; sauto. +apply assoc with H; auto with datatypes. +apply in_or_app; right; auto with datatypes. +apply T0; try apply incl_tran with (2 := T2); auto with datatypes. +case H3; replace a with (op (op a c) (G.(i) c)); auto with datatypes. +apply H6; sauto. +apply incl_tran with (2 := H2); auto with datatypes. +apply trans_equal with (op a (op c (G.(i) c))); sauto. +apply sym_equal; apply assoc with H; auto with datatypes. +replace (op c (G.(i) c)) with (G.(e)); sauto. +rewrite <- same_e_for_H_and_G. +assert (In a H.(s)); sauto; apply (H2 a); auto with datatypes. +unfold mkGH; apply H1; auto with datatypes. +Qed. + +(************************************** + Lagrange theorem + **************************************) + +Theorem lagrange: (g_order G | (g_order H)). +unfold g_order. +rewrite Permutation.permutation_length with (l := H.(s)) (m:= mkGH). +case mkGH_length; intros x H1; exists (Z_of_nat x). +rewrite H1; rewrite Zmult_comm; apply inj_mult. +apply ulist_incl2_permutation; auto. +apply ulist_mkGH. +apply mkGH_incl. +apply incl_mkGH. +Qed. + +End Lagrange. diff --git a/coqprime-8.5/Coqprime/ListAux.v b/coqprime-8.5/Coqprime/ListAux.v new file mode 100644 index 000000000..c3c9602bd --- /dev/null +++ b/coqprime-8.5/Coqprime/ListAux.v @@ -0,0 +1,271 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Aux.v + + Auxillary functions & Theorems + **********************************************************************) +Require Export List. +Require Export Arith. +Require Export Tactic. +Require Import Inverse_Image. +Require Import Wf_nat. + +(************************************** + Some properties on list operators: app, map,... +**************************************) + +Section List. +Variables (A : Set) (B : Set) (C : Set). +Variable f : A -> B. + +(************************************** + An induction theorem for list based on length +**************************************) + +Theorem list_length_ind: + forall (P : list A -> Prop), + (forall (l1 : list A), + (forall (l2 : list A), length l2 < length l1 -> P l2) -> P l1) -> + forall (l : list A), P l. +intros P H l; + apply well_founded_ind with ( R := fun (x y : list A) => length x < length y ); + auto. +apply wf_inverse_image with ( R := lt ); auto. +apply lt_wf. +Qed. + +Definition list_length_induction: + forall (P : list A -> Set), + (forall (l1 : list A), + (forall (l2 : list A), length l2 < length l1 -> P l2) -> P l1) -> + forall (l : list A), P l. +intros P H l; + apply well_founded_induction + with ( R := fun (x y : list A) => length x < length y ); auto. +apply wf_inverse_image with ( R := lt ); auto. +apply lt_wf. +Qed. + +Theorem in_ex_app: + forall (a : A) (l : list A), + In a l -> (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) ). +intros a l; elim l; clear l; simpl; auto. +intros H; case H. +intros a1 l H [H1|H1]; auto. +exists (nil (A:=A)); exists l; simpl; auto. +rewrite H1; auto. +case H; auto; intros l1 [l2 Hl2]; exists (a1 :: l1); exists l2; simpl; auto. +rewrite Hl2; auto. +Qed. + +(************************************** + Properties on app +**************************************) + +Theorem length_app: + forall (l1 l2 : list A), length (l1 ++ l2) = length l1 + length l2. +intros l1; elim l1; simpl; auto. +Qed. + +Theorem app_inv_head: + forall (l1 l2 l3 : list A), l1 ++ l2 = l1 ++ l3 -> l2 = l3. +intros l1; elim l1; simpl; auto. +intros a l H l2 l3 H0; apply H; injection H0; auto. +Qed. + +Theorem app_inv_tail: + forall (l1 l2 l3 : list A), l2 ++ l1 = l3 ++ l1 -> l2 = l3. +intros l1 l2; generalize l1; elim l2; clear l1 l2; simpl; auto. +intros l1 l3; case l3; auto. +intros b l H; absurd (length ((b :: l) ++ l1) <= length l1). +simpl; rewrite length_app; auto with arith. +rewrite <- H; auto with arith. +intros a l H l1 l3; case l3. +simpl; intros H1; absurd (length (a :: (l ++ l1)) <= length l1). +simpl; rewrite length_app; auto with arith. +rewrite H1; auto with arith. +simpl; intros b l0 H0; injection H0. +intros H1 H2; rewrite H2, (H _ _ H1); auto. +Qed. + +Theorem app_inv_app: + forall l1 l2 l3 l4 a, + l1 ++ l2 = l3 ++ (a :: l4) -> + (exists l5 : list A , l1 = l3 ++ (a :: l5) ) \/ + (exists l5 , l2 = l5 ++ (a :: l4) ). +intros l1; elim l1; simpl; auto. +intros l2 l3 l4 a H; right; exists l3; auto. +intros a l H l2 l3 l4 a0; case l3; simpl. +intros H0; left; exists l; injection H0; intros; subst; auto. +intros b l0 H0; case (H l2 l0 l4 a0); auto. +injection H0; auto. +intros [l5 H1]. +left; exists l5; injection H0; intros; subst; auto. +Qed. + +Theorem app_inv_app2: + forall l1 l2 l3 l4 a b, + l1 ++ l2 = l3 ++ (a :: (b :: l4)) -> + (exists l5 : list A , l1 = l3 ++ (a :: (b :: l5)) ) \/ + ((exists l5 , l2 = l5 ++ (a :: (b :: l4)) ) \/ + l1 = l3 ++ (a :: nil) /\ l2 = b :: l4). +intros l1; elim l1; simpl; auto. +intros l2 l3 l4 a b H; right; left; exists l3; auto. +intros a l H l2 l3 l4 a0 b; case l3; simpl. +case l; simpl. +intros H0; right; right; injection H0; split; auto. +rewrite H2; auto. +intros b0 l0 H0; left; exists l0; injection H0; intros; subst; auto. +intros b0 l0 H0; case (H l2 l0 l4 a0 b); auto. +injection H0; auto. +intros [l5 HH1]; left; exists l5; injection H0; intros; subst; auto. +intros [H1|[H1 H2]]; auto. +right; right; split; auto; injection H0; intros; subst; auto. +Qed. + +Theorem same_length_ex: + forall (a : A) l1 l2 l3, + length (l1 ++ (a :: l2)) = length l3 -> + (exists l4 , + exists l5 , + exists b : B , + length l1 = length l4 /\ (length l2 = length l5 /\ l3 = l4 ++ (b :: l5)) ). +intros a l1; elim l1; simpl; auto. +intros l2 l3; case l3; simpl; (try (intros; discriminate)). +intros b l H; exists (nil (A:=B)); exists l; exists b; (repeat (split; auto)). +intros a0 l H l2 l3; case l3; simpl; (try (intros; discriminate)). +intros b l0 H0. +case (H l2 l0); auto. +intros l4 [l5 [b1 [HH1 [HH2 HH3]]]]. +exists (b :: l4); exists l5; exists b1; (repeat (simpl; split; auto)). +rewrite HH3; auto. +Qed. + +(************************************** + Properties on map +**************************************) + +Theorem in_map_inv: + forall (b : B) (l : list A), + In b (map f l) -> (exists a : A , In a l /\ b = f a ). +intros b l; elim l; simpl; auto. +intros tmp; case tmp. +intros a0 l0 H [H1|H1]; auto. +exists a0; auto. +case (H H1); intros a1 [H2 H3]; exists a1; auto. +Qed. + +Theorem in_map_fst_inv: + forall a (l : list (B * C)), + In a (map (fst (B:=_)) l) -> (exists c , In (a, c) l ). +intros a l; elim l; simpl; auto. +intros H; case H. +intros a0 l0 H [H0|H0]; auto. +exists (snd a0); left; rewrite <- H0; case a0; simpl; auto. +case H; auto; intros l1 Hl1; exists l1; auto. +Qed. + +Theorem length_map: forall l, length (map f l) = length l. +intros l; elim l; simpl; auto. +Qed. + +Theorem map_app: forall l1 l2, map f (l1 ++ l2) = map f l1 ++ map f l2. +intros l; elim l; simpl; auto. +intros a l0 H l2; rewrite H; auto. +Qed. + +Theorem map_length_decompose: + forall l1 l2 l3 l4, + length l1 = length l2 -> + map f (app l1 l3) = app l2 l4 -> map f l1 = l2 /\ map f l3 = l4. +intros l1; elim l1; simpl; auto; clear l1. +intros l2; case l2; simpl; auto. +intros; discriminate. +intros a l1 Rec l2; case l2; simpl; clear l2; auto. +intros; discriminate. +intros b l2 l3 l4 H1 H2. +injection H2; clear H2; intros H2 H3. +case (Rec l2 l3 l4); auto. +intros H4 H5; split; auto. +subst; auto. +Qed. + +(************************************** + Properties of flat_map +**************************************) + +Theorem in_flat_map: + forall (l : list B) (f : B -> list C) a b, + In a (f b) -> In b l -> In a (flat_map f l). +intros l g; elim l; simpl; auto. +intros a l0 H a0 b H0 [H1|H1]; apply in_or_app; auto. +left; rewrite H1; auto. +right; apply H with ( b := b ); auto. +Qed. + +Theorem in_flat_map_ex: + forall (l : list B) (f : B -> list C) a, + In a (flat_map f l) -> (exists b , In b l /\ In a (f b) ). +intros l g; elim l; simpl; auto. +intros a H; case H. +intros a l0 H a0 H0; case in_app_or with ( 1 := H0 ); simpl; auto. +intros H1; exists a; auto. +intros H1; case H with ( 1 := H1 ). +intros b [H2 H3]; exists b; simpl; auto. +Qed. + +(************************************** + Properties of fold_left +**************************************) + +Theorem fold_left_invol: + forall (f: A -> B -> A) (P: A -> Prop) l a, + P a -> (forall x y, P x -> P (f x y)) -> P (fold_left f l a). +intros f1 P l; elim l; simpl; auto. +Qed. + +Theorem fold_left_invol_in: + forall (f: A -> B -> A) (P: A -> Prop) l a b, + In b l -> (forall x, P (f x b)) -> (forall x y, P x -> P (f x y)) -> + P (fold_left f l a). +intros f1 P l; elim l; simpl; auto. +intros a1 b HH; case HH. +intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto. +apply fold_left_invol; auto. +apply Rec with (b := b); auto. +Qed. + +End List. + + +(************************************** + Propertie of list_prod +**************************************) + +Theorem length_list_prod: + forall (A : Set) (l1 l2 : list A), + length (list_prod l1 l2) = length l1 * length l2. +intros A l1 l2; elim l1; simpl; auto. +intros a l H; rewrite length_app; rewrite length_map; rewrite H; auto. +Qed. + +Theorem in_list_prod_inv: + forall (A B : Set) a l1 l2, + In a (list_prod l1 l2) -> + (exists b : A , exists c : B , a = (b, c) /\ (In b l1 /\ In c l2) ). +intros A B a l1 l2; elim l1; simpl; auto; clear l1. +intros H; case H. +intros a1 l1 H1 H2. +case in_app_or with ( 1 := H2 ); intros H3; auto. +case in_map_inv with ( 1 := H3 ); intros b1 [Hb1 Hb2]; auto. +exists a1; exists b1; split; auto. +case H1; auto; intros b1 [c1 [Hb1 [Hb2 Hb3]]]. +exists b1; exists c1; split; auto. +Qed. diff --git a/coqprime-8.5/Coqprime/LucasLehmer.v b/coqprime-8.5/Coqprime/LucasLehmer.v new file mode 100644 index 000000000..a0e3b8e46 --- /dev/null +++ b/coqprime-8.5/Coqprime/LucasLehmer.v @@ -0,0 +1,597 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + LucasLehamer.v + + Build the sequence for the primality test of Mersenne numbers + + Definition: LucasLehmer + **********************************************************************) +Require Import ZArith. +Require Import ZCAux. +Require Import Tactic. +Require Import Wf_nat. +Require Import NatAux. +Require Import UList. +Require Import ListAux. +Require Import FGroup. +Require Import EGroup. +Require Import PGroup. +Require Import IGroup. + +Open Scope Z_scope. + +(************************************** + The seeds of the serie + **************************************) + +Definition w := (2, 1). + +Definition v := (2, -1). + +Theorem w_plus_v: pplus w v = (4, 0). +simpl; auto. +Qed. + +Theorem w_mult_v : pmult w v = (1, 0). +simpl; auto. +Qed. + +(************************************** + Definition of the power function for pairs p^n + **************************************) + +Definition ppow p n := match n with Zpos q => iter_pos _ (pmult p) (1, 0) q | _ => (1, 0) end. + +(************************************** + Some properties of ppow + **************************************) + +Theorem ppow_0: forall n, ppow n 0 = (1, 0). +simpl; auto. +Qed. + +Theorem ppow_1: forall n, ppow (1, 0) n = (1, 0). +intros n; case n; simpl; auto. +intros p; apply iter_pos_invariant with (Inv := fun x => x = (1, 0)); auto. +intros x H; rewrite H; auto. +Qed. + +Theorem ppow_op: forall a b p, iter_pos _ (pmult a) b p = pmult (iter_pos _ (pmult a) (1, 0) p) b. +intros a b p; generalize b; elim p; simpl; auto; clear b p. +intros p Rec b. +rewrite (Rec b). +try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos _ x y p)); auto. +repeat rewrite pmult_assoc; auto. +intros p Rec b. +rewrite (Rec b); try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos _ x y p)); auto. +repeat rewrite pmult_assoc; auto. +intros b; rewrite pmult_1_r; auto. +Qed. + +Theorem ppow_add: forall n m p, 0 <= m -> 0 <= p -> ppow n (m + p) = pmult (ppow n m) (ppow n p). +intros n m; case m; clear m. +intros p _ _; rewrite ppow_0; rewrite pmult_1_l; auto. +2: intros p m H; contradict H; auto with zarith. +intros p1 m _; case m. +intros _; rewrite Zplus_0_r; simpl; apply sym_equal; apply pmult_1_r. +2: intros p2 H; contradict H; auto with zarith. +intros p2 _; simpl. +rewrite iter_pos_plus. +rewrite ppow_op; auto. +Qed. + +Theorem ppow_ppow: forall n m p, 0 <= n -> 0 <= m -> ppow p (n * m ) = ppow (ppow p n) m. +intros n m; case n. +intros p _ Hm; rewrite Zmult_0_l. +rewrite ppow_0; apply sym_equal; apply ppow_1. +2: intros p p1 H; contradict H; auto with zarith. +intros p1 p _; case m; simpl; auto. +intros p2 _; pattern p2; apply Pind; simpl; auto. +rewrite Pmult_1_r; rewrite pmult_1_r; auto. +intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l. +rewrite Pmult_1_r. +simpl; repeat rewrite iter_pos_plus; simpl. +rewrite pmult_1_r. +rewrite ppow_op; try rewrite Rec; auto. +apply sym_equal; apply ppow_op; auto. +Qed. + + +Theorem ppow_mult: forall n m p, 0 <= n -> ppow (pmult m p) n = pmult (ppow m n) (ppow p n). +intros n m p; case n; simpl; auto. +intros p1 _; pattern p1; apply Pind; simpl; auto. +repeat rewrite pmult_1_r; auto. +intros p3 Rec; rewrite Pplus_one_succ_r. +repeat rewrite iter_pos_plus; simpl. +repeat rewrite (fun x y z => ppow_op x (pmult y z)) ; auto. +rewrite Rec. +repeat rewrite pmult_1_r; auto. +repeat rewrite <- pmult_assoc; try eq_tac; auto. +rewrite (fun x y => pmult_comm (iter_pos _ x y p3) p); auto. +rewrite (pmult_assoc m); try apply pmult_comm; auto. +Qed. + +(************************************** + We can now define our series of pairs s + **************************************) + +Definition s n := pplus (ppow w (2 ^ n)) (ppow v (2 ^ n)). + +(************************************** + Some properties of s + **************************************) + +Theorem s0 : s 0 = (4, 0). +simpl; auto. +Qed. + +Theorem sn_aux: forall n, 0 <= n -> s (n+1) = (pplus (pmult (s n) (s n)) (-2, 0)). +intros n Hn. +assert (Hu: 0 <= 2 ^n); auto with zarith. +set (y := (fst (s n) * fst (s n) - 2, 0)). +unfold s; simpl; rewrite Zpower_exp; auto with zarith. +rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith. +repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l. +repeat rewrite <- pplus_assoc. +eq_tac; auto. +pattern 2 at 2; replace 2 with (1 + 1); auto with zarith. +rewrite ppow_add; auto with zarith; simpl. +rewrite pmult_1_r; auto. +rewrite Zmult_comm; rewrite ppow_ppow; simpl; auto with zarith. +repeat rewrite <- ppow_mult; auto with zarith. +rewrite (pmult_comm v w); rewrite w_mult_v. +rewrite ppow_1. +repeat rewrite tpower_1. +rewrite pplus_comm; repeat rewrite <- pplus_assoc; +rewrite pplus_comm; repeat rewrite <- pplus_assoc. +simpl; case (ppow (7, -4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith. +Qed. + +Theorem sn_snd: forall n, snd (s n) = 0. +intros n; case n; simpl; auto. +intros p; pattern p; apply Pind; auto. +intros p1 H; rewrite Zpos_succ_morphism; unfold Zsucc. +rewrite sn_aux; auto with zarith. +generalize H; case (s (Zpos p1)); simpl. +intros x y H1; rewrite H1; auto with zarith. +Qed. + +Theorem sn: forall n, 0 <= n -> s (n+1) = (fst (s n) * fst (s n) -2, 0). +intros n Hn; rewrite sn_aux; generalize (sn_snd n); case (s n); auto. +intros x y H; simpl in H; rewrite H; simpl. +eq_tac; ring. +Qed. + +Theorem sn_w: forall n, 0 <= n -> ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0). +intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith. +assert (Hu: 0 <= 2 ^n); auto with zarith. +rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith. +repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l. +pattern 2 at 2; replace 2 with (1 + 1); auto with zarith. +rewrite ppow_add; auto with zarith; simpl. +rewrite pmult_1_r; auto. +repeat rewrite <- ppow_mult; auto with zarith. +rewrite (pmult_comm v w); rewrite w_mult_v. +rewrite ppow_1; simpl. +simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith. +Qed. + +Theorem sn_w_next: forall n, 0 <= n -> ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0). +intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith. +assert (Hu: 0 <= 2 ^n); auto with zarith. +rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith. +repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l. +pattern 2 at 2; replace 2 with (1 + 1); auto with zarith. +rewrite ppow_add; auto with zarith; simpl. +rewrite pmult_1_r; auto. +repeat rewrite <- ppow_mult; auto with zarith. +rewrite (pmult_comm v w); rewrite w_mult_v. +rewrite ppow_1; simpl. +simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith. +Qed. + +Section Lucas. + +Variable p: Z. + +(************************************** + Definition of the mersenne number + **************************************) + +Definition Mp := 2^p -1. + +Theorem mersenne_pos: 1 < p -> 1 < Mp. +intros H; unfold Mp; assert (2 < 2 ^p); auto with zarith. +apply Zlt_le_trans with (2^2); auto with zarith. +refine (refl_equal _). +apply Zpower_le_monotone; auto with zarith. +Qed. + +Hypothesis p_pos2: 2 < p. + +(************************************** + We suppose that the mersenne number divides s + **************************************) + +Hypothesis Mp_divide_sn: (Mp | fst (s (p - 2))). + +Variable q: Z. + +(************************************** + We take a divisor of Mp and shows that Mp <= q^2, hence Mp is prime + **************************************) + +Hypothesis q_divide_Mp: (q | Mp). + +Hypothesis q_pos2: 2 < q. + +Theorem q_pos: 1 < q. +apply Zlt_trans with (2 := q_pos2); auto with zarith. +Qed. + +(************************************** + The definition of the groups of inversible pairs + **************************************) + +Definition pgroup := PGroup q q_pos. + +Theorem w_in_pgroup: (In w pgroup.(FGroup.s)). +generalize q_pos; intros HM. +generalize q_pos2; intros HM2. +assert (H0: 0 < q); auto with zarith. +simpl; apply isupport_is_in; auto. +assert (zpmult q w (2, q - 1) = (1, 0)). +unfold zpmult, w, pmult, base; repeat (rewrite Zmult_1_r || rewrite Zmult_1_l). +eq_tac. +apply trans_equal with ((3 * q + 1) mod q). +eq_tac; auto with zarith. +rewrite Zplus_mod; auto. +rewrite Zmult_mod; auto. +rewrite Z_mod_same; auto with zarith. +rewrite Zmult_0_r; repeat rewrite Zmod_small; auto with zarith. +apply trans_equal with (2 * q mod q). +eq_tac; auto with zarith. +apply Zdivide_mod; auto with zarith; exists 2; auto with zarith. +apply is_inv_true with (2, q - 1); auto. +apply mL_in; auto with zarith. +intros; apply zpmult_1_l; auto with zarith. +intros; apply zpmult_1_r; auto with zarith. +rewrite zpmult_comm; auto. +apply mL_in; auto with zarith. +unfold w; apply mL_in; auto with zarith. +Qed. + +Theorem e_order_divide_order: (e_order P_dec w pgroup | g_order pgroup). +apply e_order_divide_g_order. +apply w_in_pgroup. +Qed. + +Theorem order_lt: g_order pgroup < q * q. +unfold g_order, pgroup, PGroup; simpl. +rewrite <- (Zabs_eq (q * q)); auto with zarith. +rewrite <- (inj_Zabs_nat (q * q)); auto with zarith. +rewrite <- mL_length; auto with zarith. +apply inj_lt; apply isupport_length_strict with (0, 0). +apply mL_ulist. +apply mL_in; auto with zarith. +intros a _; left; rewrite zpmult_0_l; auto with zarith. +intros; discriminate. +Qed. + +(************************************** + The power function zpow: a^n + **************************************) + +Definition zpow a := gpow a pgroup. + +(************************************** + Some properties of zpow + **************************************) + +Theorem zpow_def: + forall a b, In a pgroup.(FGroup.s) -> 0 <= b -> + zpow a b = ((fst (ppow a b)) mod q, (snd (ppow a b)) mod q). +generalize q_pos; intros HM. +generalize q_pos2; intros HM2. +assert (H0: 0 < q); auto with zarith. +intros a b Ha Hb; generalize Hb; pattern b; apply natlike_ind; auto. +intros _; repeat rewrite Zmod_small; auto with zarith. +rewrite ppow_0; simpl; auto with zarith. +unfold zpow; intros n1 H Rec _; unfold Zsucc. +rewrite gpow_add; auto with zarith. +rewrite ppow_add; simpl; try rewrite pmult_1_r; auto with zarith. +rewrite Rec; unfold zpmult; auto with zarith. +case (ppow a n1); case a; unfold pmult, fst, snd. +intros x y z t. +repeat (rewrite Zmult_1_r || rewrite Zmult_0_r || rewrite Zplus_0_r || rewrite Zplus_0_l); eq_tac. +repeat rewrite (fun u v => Zplus_mod (u * v)); auto. +eq_tac; try eq_tac; auto. +repeat rewrite (Zmult_mod z); auto with zarith. +repeat rewrite (fun u v => Zmult_mod (u * v)); auto. +eq_tac; try eq_tac; auto with zarith. +repeat rewrite (Zmult_mod base); auto with zarith. +eq_tac; try eq_tac; auto with zarith. +apply Zmod_mod; auto. +apply Zmod_mod; auto. +repeat rewrite (fun u v => Zplus_mod (u * v)); auto. +eq_tac; try eq_tac; auto. +repeat rewrite (Zmult_mod z); auto with zarith. +repeat rewrite (Zmult_mod t); auto with zarith. +Qed. + +Theorem zpow_w_n_minus_1: zpow w (2 ^ (p - 1)) = (-1 mod q, 0). +generalize q_pos; intros HM. +generalize q_pos2; intros HM2. +assert (H0: 0 < q); auto with zarith. +rewrite zpow_def. +replace (p - 1) with ((p - 2) + 1); auto with zarith. +rewrite sn_w; auto with zarith. +generalize Mp_divide_sn (sn_snd (p - 2)); case (s (p -2)); case (ppow w (2 ^ (p -2))). +unfold fst, snd; intros x y z t H1 H2; unfold pmult, pplus; subst. +repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l || rewrite Zplus_0_r). +assert (H2: z mod q = 0). +case H1; intros q1 Hq1; rewrite Hq1. +case q_divide_Mp; intros q2 Hq2; rewrite Hq2. +rewrite Zmult_mod; auto. +rewrite (Zmult_mod q2); auto. +rewrite Z_mod_same; auto with zarith. +repeat (rewrite Zmult_0_r; rewrite (Zmod_small 0)); auto with zarith. +assert (H3: forall x, (z * x) mod q = 0). +intros y1; rewrite Zmult_mod; try rewrite H2; auto. +assert (H4: forall x y, (z * x + y) mod q = y mod q). +intros x1 y1; rewrite Zplus_mod; try rewrite H3; auto. +rewrite Zplus_0_l; apply Zmod_mod; auto. +eq_tac; auto. +apply w_in_pgroup. +apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. +Qed. + +Theorem zpow_w_n: zpow w (2 ^ p) = (1, 0). +generalize q_pos; intros HM. +generalize q_pos2; intros HM2. +assert (H0: 0 < q); auto with zarith. +replace p with ((p - 1) + 1); auto with zarith. +rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +unfold zpow; rewrite gpow_gpow; auto with zarith. +generalize zpow_w_n_minus_1; unfold zpow; intros H1; rewrite H1; clear H1. +simpl; unfold zpmult, pmult. +repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l || + rewrite Zplus_0_r || rewrite Zmult_1_r). +eq_tac; auto. +pattern (-1 mod q) at 1; rewrite <- (Zmod_mod (-1) q); auto with zarith. +repeat rewrite <- Zmult_mod; auto. +rewrite Zmod_small; auto with zarith. +apply w_in_pgroup. +Qed. + +(************************************** + As e = (1, 0), the previous equation implies that the order of the group divide 2^p + **************************************) + +Theorem e_order_divide_pow: (e_order P_dec w pgroup | 2 ^ p). +generalize q_pos; intros HM. +generalize q_pos2; intros HM2. +assert (H0: 0 < q); auto with zarith. +apply e_order_divide_gpow. +apply w_in_pgroup. +apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. +exact zpow_w_n. +Qed. + +(************************************** + So it is less than equal + **************************************) + +Theorem e_order_le_pow : e_order P_dec w pgroup <= 2 ^ p. +apply Zdivide_le. +apply Zlt_le_weak; apply e_order_pos. +apply Zpower_gt_0; auto with zarith. +apply e_order_divide_pow. +Qed. + +(************************************** + So order(w) must be 2^q + **************************************) + +Theorem e_order_eq_pow: exists q, (e_order P_dec w pgroup) = 2 ^ q. +case (Zdivide_power_2 (e_order P_dec w pgroup) 2 p); auto with zarith. +apply Zlt_le_weak; apply e_order_pos. +apply prime_2. +apply e_order_divide_pow; auto. +intros x H; exists x; auto with zarith. +Qed. + +(************************************** + Buth this q can only be p otherwise it would contradict w^2^(p -1) = (-1, 0) + **************************************) + +Theorem e_order_eq_p: e_order P_dec w pgroup = 2 ^ p. +case (Zdivide_power_2 (e_order P_dec w pgroup) 2 p); auto with zarith. +apply Zlt_le_weak; apply e_order_pos. +apply prime_2. +apply e_order_divide_pow; auto. +intros p1 Hp1. +case (Zle_lt_or_eq p1 p); try (intro H1; subst; auto; fail). +case (Zle_or_lt p1 p); auto; intros H1. +absurd (2 ^ p1 <= 2 ^ p); auto with zarith. +apply Zlt_not_le; apply Zpower_lt_monotone; auto with zarith. +apply Zdivide_le. +apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. +apply Zpower_gt_0; auto with zarith. +rewrite <- Hp1; apply e_order_divide_pow. +intros H1. +assert (Hu: 0 <= p1). +generalize Hp1; case p1; simpl; auto with zarith. +intros p2 Hu; absurd (0 < e_order P_dec w pgroup). +rewrite Hu; auto with zarith. +apply e_order_pos. +absurd (zpow w (2 ^ (p - 1)) = (1, 0)). +rewrite zpow_w_n_minus_1. +intros H2; injection H2; clear H2; intros H2. +assert (H0: 0 < q); auto with zarith. +absurd (0 mod q = 0). +pattern 0 at 1; replace 0 with (-1 + 1); auto with zarith. +rewrite Zplus_mod; auto with zarith. +rewrite H2; rewrite (Zmod_small 1); auto with zarith. +rewrite Zmod_small; auto with zarith. +rewrite Zmod_small; auto with zarith. +unfold zpow; apply (gpow_pow _ _ w pgroup) with p1; auto with zarith. +apply w_in_pgroup. +rewrite <- Hp1. +apply (gpow_e_order_is_e _ P_dec _ w pgroup). +apply w_in_pgroup. +Qed. + +(************************************** + We have then the expected conclusion + **************************************) + +Theorem q_more_than_square: Mp < q * q. +unfold Mp. +assert (2 ^ p <= q * q); auto with zarith. +rewrite <- e_order_eq_p. +apply Zle_trans with (g_order pgroup). +apply Zdivide_le; auto with zarith. +apply Zlt_le_weak; apply e_order_pos; auto with zarith. +2: apply e_order_divide_order. +2: apply Zlt_le_weak; apply order_lt. +apply Zlt_le_trans with 2; auto with zarith. +replace 2 with (Z_of_nat (length ((1, 0)::w::nil))); auto. +unfold g_order; apply inj_le. +apply ulist_incl_length. +apply ulist_cons; simpl; auto. +unfold w; intros [H2 | H2]; try (case H2; fail); discriminate. +intro a; simpl; intros [H1 | [H1 | H1]]; subst. +assert (In (1, 0) (mL q)). +apply mL_in; auto with zarith. +apply isupport_is_in; auto. +apply is_inv_true with (1, 0); simpl; auto. +intros; apply zpmult_1_l; auto with zarith. +intros; apply zpmult_1_r; auto with zarith. +rewrite zpmult_1_r; auto with zarith. +rewrite zpmult_1_r; auto with zarith. +exact w_in_pgroup. +case H1. +Qed. + +End Lucas. + +(************************************** + We build the sequence in Z + **************************************) + +Definition SS p := + let n := Mp p in + match p - 2 with + Zpos p1 => iter_pos _ (fun x => Zmodd (Zsquare x - 2) n) (Zmodd 4 n) p1 + | _ => (Zmodd 4 n) + end. + +Theorem SS_aux_correct: + forall p z1 z2 n, 0 <= n -> 0 < z1 -> z2 = fst (s n) mod z1 -> + iter_pos _ (fun x => Zmodd (Zsquare x - 2) z1) z2 p = fst (s (n + Zpos p)) mod z1. +intros p; pattern p; apply Pind. +simpl. +intros z1 z2 n Hn H H1; rewrite sn; auto; rewrite H1; rewrite Zmodd_correct; rewrite Zsquare_correct; simpl. +unfold Zminus; rewrite Zplus_mod; auto. +rewrite (Zplus_mod (fst (s n) * fst (s n))); auto with zarith. +eq_tac; auto. +eq_tac; auto. +apply sym_equal; apply Zmult_mod; auto. +intros n Rec z1 z2 n1 Hn1 H1 H2. +rewrite Pplus_one_succ_l; rewrite iter_pos_plus. +rewrite Rec with (n0 := n1); auto. +replace (n1 + Zpos (1 + n)) with ((n1 + Zpos n) + 1); auto with zarith. +rewrite sn; simpl; try rewrite Zmodd_correct; try rewrite Zsquare_correct; simpl; auto with zarith. +unfold Zminus; rewrite Zplus_mod; auto. +unfold Zmodd. +rewrite (Zplus_mod (fst (s (n1 + Zpos n)) * fst (s (n1 + Zpos n)))); auto with zarith. +eq_tac; auto. +eq_tac; auto. +apply sym_equal; apply Zmult_mod; auto. +rewrite Zpos_plus_distr; auto with zarith. +Qed. + +Theorem SS_prop: forall n, 1 < n -> SS n = fst(s (n -2)) mod (Mp n). +intros n Hn; unfold SS. +cut (0 <= n - 2); auto with zarith. +case (n - 2). +intros _; rewrite Zmodd_correct; rewrite s0; auto. +intros p1 H2; rewrite SS_aux_correct with (n := 0); auto with zarith. +apply Zle_lt_trans with 1; try apply mersenne_pos; auto with zarith. +rewrite Zmodd_correct; rewrite s0; auto. +intros p1 H2; case H2; auto. +Qed. + +Theorem SS_prop_cor: forall p, 1 < p -> SS p = 0 -> (Mp p | fst(s (p -2))). +intros p H H1. +apply Zmod_divide. +generalize (mersenne_pos _ H); auto with zarith. +apply trans_equal with (2:= H1); apply sym_equal; apply SS_prop; auto. +Qed. + +Theorem LucasLehmer: forall p, 2 < p -> SS p = 0 -> prime (Mp p). +intros p H H1; case (prime_dec (Mp p)); auto; intros H2. +case Zdivide_div_prime_le_square with (2 := H2). +apply mersenne_pos; apply Zlt_trans with 2; auto with zarith. +intros q (H3, (H4, H5)). +contradict H5; apply Zlt_not_le. +apply q_more_than_square; auto. +apply SS_prop_cor; auto. +apply Zlt_trans with 2; auto with zarith. +case (Zle_lt_or_eq 2 q); auto. +apply prime_ge_2; auto. +intros H5; subst. +absurd (2 <= 1); auto with arith. +apply Zdivide_le; auto with zarith. +case H4; intros x Hx. +exists (2 ^ (p -1) - x). +rewrite Zmult_minus_distr_r; rewrite <- Hx; unfold Mp. +pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; auto with zarith. +replace (p - 1 + 1) with p; auto with zarith. +Qed. + +(************************************** + The test + **************************************) + +Definition lucas_test n := + if Z_lt_dec 2 n then if Z_eq_dec (SS n) 0 then true else false else false. + +Theorem LucasTest: forall n, lucas_test n = true -> prime (Mp n). +intros n; unfold lucas_test; case (Z_lt_dec 2 n); intros H1; try (intros; discriminate). +case (Z_eq_dec (SS n) 0); intros H2; try (intros; discriminate). +intros _; apply LucasLehmer; auto. +Qed. + +Theorem prime7: prime 7. +exact (LucasTest 3 (refl_equal _)). +Qed. + +Theorem prime31: prime 31. +exact (LucasTest 5 (refl_equal _)). +Qed. + +Theorem prime127: prime 127. +exact (LucasTest 7 (refl_equal _)). +Qed. + +Theorem prime8191: prime 8191. +exact (LucasTest 13 (refl_equal _)). +Qed. + +Theorem prime131071: prime 131071. +exact (LucasTest 17 (refl_equal _)). +Qed. + +Theorem prime524287: prime 524287. +exact (LucasTest 19 (refl_equal _)). +Qed. + diff --git a/coqprime-8.5/Coqprime/NatAux.v b/coqprime-8.5/Coqprime/NatAux.v new file mode 100644 index 000000000..eab09150c --- /dev/null +++ b/coqprime-8.5/Coqprime/NatAux.v @@ -0,0 +1,72 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Aux.v + + Auxillary functions & Theorems + **********************************************************************) +Require Export Arith. + +(************************************** + Some properties of minus +**************************************) + +Theorem minus_O : forall a b : nat, a <= b -> a - b = 0. +intros a; elim a; simpl in |- *; auto with arith. +intros a1 Rec b; case b; elim b; auto with arith. +Qed. + + +(************************************** + Definitions and properties of the power for nat +**************************************) + +Fixpoint pow (n m: nat) {struct m} : nat := match m with O => 1%nat | (S m1) => (n * pow n m1)%nat end. + +Theorem pow_add: forall n m p, pow n (m + p) = (pow n m * pow n p)%nat. +intros n m; elim m; simpl. +intros p; rewrite plus_0_r; auto. +intros m1 Rec p; rewrite Rec; auto with arith. +Qed. + + +Theorem pow_pos: forall p n, (0 < p)%nat -> (0 < pow p n)%nat. +intros p1 n H; elim n; simpl; auto with arith. +intros n1 H1; replace 0%nat with (p1 * 0)%nat; auto with arith. +repeat rewrite (mult_comm p1); apply mult_lt_compat_r; auto with arith. +Qed. + + +Theorem pow_monotone: forall n p q, (1 < n)%nat -> (p < q)%nat -> (pow n p < pow n q)%nat. +intros n p1 q1 H H1; elim H1; simpl. +pattern (pow n p1) at 1; rewrite <- (mult_1_l (pow n p1)). +apply mult_lt_compat_r; auto. +apply pow_pos; auto with arith. +intros n1 H2 H3. +apply lt_trans with (1 := H3). +pattern (pow n n1) at 1; rewrite <- (mult_1_l (pow n n1)). +apply mult_lt_compat_r; auto. +apply pow_pos; auto with arith. +Qed. + +(************************************ + Definition of the divisibility for nat +**************************************) + +Definition divide a b := exists c, b = a * c. + + +Theorem divide_le: forall p q, (1 < q)%nat -> divide p q -> (p <= q)%nat. +intros p1 q1 H (x, H1); subst. +apply le_trans with (p1 * 1)%nat; auto with arith. +rewrite mult_1_r; auto with arith. +apply mult_le_compat_l. +case (le_lt_or_eq 0 x); auto with arith. +intros H2; subst; contradict H; rewrite mult_0_r; auto with arith. +Qed. diff --git a/coqprime-8.5/Coqprime/PGroup.v b/coqprime-8.5/Coqprime/PGroup.v new file mode 100644 index 000000000..e9c1b2f47 --- /dev/null +++ b/coqprime-8.5/Coqprime/PGroup.v @@ -0,0 +1,347 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + PGroup.v + + Build the group of pairs modulo needed for the theorem of + lucas lehmer + + Definition: PGroup + **********************************************************************) +Require Import ZArith. +Require Import Znumtheory. +Require Import Tactic. +Require Import Wf_nat. +Require Import ListAux. +Require Import UList. +Require Import FGroup. +Require Import EGroup. +Require Import IGroup. + +Open Scope Z_scope. + +Definition base := 3. + + +(************************************** + Equality is decidable on pairs + **************************************) + +Definition P_dec: forall p q: Z * Z, {p = q} + {p <> q}. +intros p1 q1; case p1; case q1; intros z t x y; case (Z_eq_dec x z); intros H1. +case (Z_eq_dec y t); intros H2. +left; eq_tac; auto. +right; contradict H2; injection H2; auto. +right; contradict H1; injection H1; auto. +Defined. + + +(************************************** + Addition of two pairs + **************************************) + +Definition pplus (p q: Z * Z) := let (x ,y) := p in let (z,t) := q in (x + z, y + t). + +(************************************** + Properties of addition + **************************************) + +Theorem pplus_assoc: forall p q r, (pplus p (pplus q r)) = (pplus (pplus p q) r). +intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus. +eq_tac; ring. +Qed. + +Theorem pplus_comm: forall p q, (pplus p q) = (pplus q p). +intros p q; case p; case q; intros q1 q2 p1 p2; unfold pplus. +eq_tac; ring. +Qed. + +(************************************** + Multiplication of two pairs + **************************************) + +Definition pmult (p q: Z * Z) := let (x ,y) := p in let (z,t) := q in (x * z + base * y * t, x * t + y * z). + +(************************************** + Properties of multiplication + **************************************) + +Theorem pmult_assoc: forall p q r, (pmult p (pmult q r)) = (pmult (pmult p q) r). +intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pmult. +eq_tac; ring. +Qed. + +Theorem pmult_0_l: forall p, (pmult (0, 0) p) = (0, 0). +intros p; case p; intros x y; unfold pmult; eq_tac; ring. +Qed. + +Theorem pmult_0_r: forall p, (pmult p (0, 0)) = (0, 0). +intros p; case p; intros x y; unfold pmult; eq_tac; ring. +Qed. + +Theorem pmult_1_l: forall p, (pmult (1, 0) p) = p. +intros p; case p; intros x y; unfold pmult; eq_tac; ring. +Qed. + +Theorem pmult_1_r: forall p, (pmult p (1, 0)) = p. +intros p; case p; intros x y; unfold pmult; eq_tac; ring. +Qed. + +Theorem pmult_comm: forall p q, (pmult p q) = (pmult q p). +intros p q; case p; case q; intros q1 q2 p1 p2; unfold pmult. +eq_tac; ring. +Qed. + +Theorem pplus_pmult_dist_l: forall p q r, (pmult p (pplus q r)) = (pplus (pmult p q) (pmult p r)). +intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus, pmult. +eq_tac; ring. +Qed. + + +Theorem pplus_pmult_dist_r: forall p q r, (pmult (pplus q r) p) = (pplus (pmult q p) (pmult r p)). +intros p q r; case p; case q; case r; intros r1 r2 q1 q2 p1 p2; unfold pplus, pmult. +eq_tac; ring. +Qed. + +(************************************** + In this section we create the group PGroup of inversible elements {(p, q) | 0 <= p < m /\ 0 <= q < m} + **************************************) +Section Mod. + +Variable m : Z. + +Hypothesis m_pos: 1 < m. + +(************************************** + mkLine creates {(a, p) | 0 <= p < n} + **************************************) + +Fixpoint mkLine (a: Z) (n: nat) {struct n} : list (Z * Z) := + (a, Z_of_nat n) :: match n with O => nil | (S n1) => mkLine a n1 end. + +(************************************** + Some properties of mkLine + **************************************) + +Theorem mkLine_length: forall a n, length (mkLine a n) = (n + 1)%nat. +intros a n; elim n; simpl; auto. +Qed. + +Theorem mkLine_in: forall a n p, 0 <= p <= Z_of_nat n -> (In (a, p) (mkLine a n)). +intros a n; elim n. +simpl; auto with zarith. +intros p (H1, H2); replace p with 0; auto with zarith. +intros n1 Rec p (H1, H2). +case (Zle_lt_or_eq p (Z_of_nat (S n1))); auto with zarith. +rewrite inj_S in H2; auto with zarith. +rewrite inj_S; auto with zarith. +intros H3; right; apply Rec; auto with zarith. +intros H3; subst; simpl; auto. +Qed. + +Theorem in_mkLine: forall a n p, In p (mkLine a n) -> exists q, 0 <= q <= Z_of_nat n /\ p = (a, q). +intros a n p; elim n; clear n. +simpl; intros [H1 | H1]; exists 0; auto with zarith; case H1. +simpl; intros n Rec [H1 | H1]; auto. +exists (Z_of_nat (S n)); auto with zarith. +case Rec; auto; intros q ((H2, H3), H4); exists q; repeat split; auto with zarith. +change (q <= Z_of_nat (S n)). +rewrite inj_S; auto with zarith. +Qed. + +Theorem mkLine_ulist: forall a n, ulist (mkLine a n). +intros a n; elim n; simpl; auto. +intros n1 H; apply ulist_cons; auto. +change (~ In (a, Z_of_nat (S n1)) (mkLine a n1)). +rewrite inj_S; intros H1. +case in_mkLine with (1 := H1); auto with zarith. +intros x ((H2, H3), H4); injection H4. +intros H5; subst; auto with zarith. +Qed. + +(************************************** + mkRect creates the list {(p, q) | 0 <= p < n /\ 0 <= q < m} + **************************************) + +Fixpoint mkRect (n m: nat) {struct n} : list (Z * Z) := + (mkLine (Z_of_nat n) m) ++ match n with O => nil | (S n1) => mkRect n1 m end. + +(************************************** + Some properties of mkRect + **************************************) + +Theorem mkRect_length: forall n m, length (mkRect n m) = ((n + 1) * (m + 1))%nat. +intros n; elim n; simpl; auto. +intros n1; rewrite <- app_nil_end; rewrite mkLine_length; rewrite plus_0_r; auto. +intros n1 Rec m1; rewrite length_app; rewrite Rec; rewrite mkLine_length; auto. +Qed. + +Theorem mkRect_in: forall n m p q, 0 <= p <= Z_of_nat n -> 0 <= q <= Z_of_nat m -> (In (p, q) (mkRect n m)). +intros n m1; elim n; simpl. +intros p q (H1, H2) (H3, H4); replace p with 0; auto with zarith. +rewrite <- app_nil_end; apply mkLine_in; auto. +intros n1 Rec p q (H1, H2) (H3, H4). +case (Zle_lt_or_eq p (Z_of_nat (S n1))); auto with zarith; intros H5. +rewrite inj_S in H5; apply in_or_app; auto with zarith. +apply in_or_app; left; subst; apply mkLine_in; auto with zarith. +Qed. + +Theorem in_mkRect: forall n m p, In p (mkRect n m) -> exists p1, exists p2, 0 <= p1 <= Z_of_nat n /\ 0 <= p2 <= Z_of_nat m /\ p = (p1, p2). +intros n m1 p; elim n; clear n; simpl. +rewrite <- app_nil_end; intros H1. +case in_mkLine with (1 := H1). +intros p2 (H2, H3); exists 0; exists p2; auto with zarith. +intros n Rec H1. +case in_app_or with (1 := H1); intros H2. +case in_mkLine with (1 := H2). +intros p2 (H3, H4); exists (Z_of_nat (S n)); exists p2; subst; simpl; auto with zarith. +case Rec with (1 := H2); auto. +intros p1 (p2, (H3, (H4, H5))); exists p1; exists p2; repeat split; auto with zarith. +change (p1 <= Z_of_nat (S n)). +rewrite inj_S; auto with zarith. +Qed. + +Theorem mkRect_ulist: forall n m, ulist (mkRect n m). +intros n; elim n; simpl; auto. +intros n1; rewrite <- app_nil_end; apply mkLine_ulist; auto. +intros n1 Rec m1; apply ulist_app; auto. +apply mkLine_ulist. +intros a H1 H2. +case in_mkLine with (1 := H1); intros p1 ((H3, H4), H5). +case in_mkRect with (1 := H2); intros p2 (p3, ((H6, H7), ((H8, H9), H10))). +subst; injection H10; clear H10; intros; subst. +contradict H7. +change (~ Z_of_nat (S n1) <= Z_of_nat n1). +rewrite inj_S; auto with zarith. +Qed. + +(************************************** + mL is the list {(p, q) | 0 <= p < m-1 /\ 0 <= q < m - 1} + **************************************) +Definition mL := mkRect (Zabs_nat (m - 1)) (Zabs_nat (m -1)). + +(************************************** + Some properties of mL + **************************************) + +Theorem mL_length : length mL = Zabs_nat (m * m). +unfold mL; rewrite mkRect_length; simpl; apply inj_eq_rev. +repeat (rewrite inj_mult || rewrite inj_plus || rewrite inj_Zabs_nat || rewrite Zabs_eq); simpl; auto with zarith. +eq_tac; auto with zarith. +Qed. + +Theorem mL_in: forall p q, 0 <= p < m -> 0 <= q < m -> (In (p, q) mL). +intros p q (H1, H2) (H3, H4); unfold mL; apply mkRect_in; rewrite inj_Zabs_nat; + rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem in_mL: forall p, In p mL-> exists p1, exists p2, 0 <= p1 < m /\ 0 <= p2 < m /\ p = (p1, p2). +unfold mL; intros p H1; case in_mkRect with (1 := H1). +repeat (rewrite inj_Zabs_nat || rewrite Zabs_eq); auto with zarith. +intros p1 (p2, ((H2, H3), ((H4, H5), H6))); exists p1; exists p2; repeat split; auto with zarith. +Qed. + +Theorem mL_ulist: ulist mL. +unfold mL; apply mkRect_ulist; auto. +Qed. + +(************************************** + We define zpmult the multiplication of pairs module m + **************************************) + +Definition zpmult (p q: Z * Z) := let (x ,y) := pmult p q in (Zmod x m, Zmod y m). + +(************************************** + Some properties of zpmult + **************************************) + +Theorem zpmult_internal: forall p q, (In (zpmult p q) mL). +intros p q; unfold zpmult; case (pmult p q); intros z y; apply mL_in; auto with zarith. +apply Z_mod_lt; auto with zarith. +apply Z_mod_lt; auto with zarith. +Qed. + +Theorem zpmult_assoc: forall p q r, (zpmult p (zpmult q r)) = (zpmult (zpmult p q) r). +assert (U: 0 < m); auto with zarith. +intros p q r; unfold zpmult. +generalize (pmult_assoc p q r). +case (pmult p q); intros x1 x2. +case (pmult q r); intros y1 y2. +case p; case r; unfold pmult. +intros z1 z2 t1 t2 H. +match goal with + H: (?X, ?Y) = (?Z, ?T) |- _ => + assert (H1: X = Z); assert (H2: Y = T); try (injection H; simpl; auto; fail); clear H +end. +eq_tac. +generalize (f_equal (fun x => x mod m) H1). +repeat rewrite <- Zmult_assoc. +repeat (rewrite (fun x => Zplus_mod (t1 * x))); auto. +repeat (rewrite (fun x => Zplus_mod (x1 * x))); auto. +repeat (rewrite (fun x => Zplus_mod (x1 mod m * x))); auto. +repeat (rewrite (Zmult_mod t1)); auto. +repeat (rewrite (Zmult_mod x1)); auto. +repeat (rewrite (Zmult_mod base)); auto. +repeat (rewrite (Zmult_mod t2)); auto. +repeat (rewrite (Zmult_mod x2)); auto. +repeat (rewrite (Zmult_mod (t2 mod m))); auto. +repeat (rewrite (Zmult_mod (x1 mod m))); auto. +repeat (rewrite (Zmult_mod (x2 mod m))); auto. +repeat (rewrite Zmod_mod); auto. +generalize (f_equal (fun x => x mod m) H2). +repeat (rewrite (fun x => Zplus_mod (t1 * x))); auto. +repeat (rewrite (fun x => Zplus_mod (x1 * x))); auto. +repeat (rewrite (fun x => Zplus_mod (x1 mod m * x))); auto. +repeat (rewrite (Zmult_mod t1)); auto. +repeat (rewrite (Zmult_mod x1)); auto. +repeat (rewrite (Zmult_mod t2)); auto. +repeat (rewrite (Zmult_mod x2)); auto. +repeat (rewrite (Zmult_mod (t2 mod m))); auto. +repeat (rewrite (Zmult_mod (x1 mod m))); auto. +repeat (rewrite (Zmult_mod (x2 mod m))); auto. +repeat (rewrite Zmod_mod); auto. +Qed. + +Theorem zpmult_0_l: forall p, (zpmult (0, 0) p) = (0, 0). +intros p; case p; intros x y; unfold zpmult, pmult; simpl. +rewrite Zmod_small; auto with zarith. +Qed. + +Theorem zpmult_1_l: forall p, In p mL -> zpmult (1, 0) p = p. +intros p H; case in_mL with (1 := H); clear H; intros p1 (p2, ((H1, H2), (H3, H4))); subst. +unfold zpmult; rewrite pmult_1_l. +repeat rewrite Zmod_small; auto with zarith. +Qed. + +Theorem zpmult_1_r: forall p, In p mL -> zpmult p (1, 0) = p. +intros p H; case in_mL with (1 := H); clear H; intros p1 (p2, ((H1, H2), (H3, H4))); subst. +unfold zpmult; rewrite pmult_1_r. +repeat rewrite Zmod_small; auto with zarith. +Qed. + +Theorem zpmult_comm: forall p q, zpmult p q = zpmult q p. +intros p q; unfold zpmult; rewrite pmult_comm; auto. +Qed. + +(************************************** + We are now ready to build our group + **************************************) + +Definition PGroup : (FGroup zpmult). +apply IGroup with (support := mL) (e:= (1, 0)). +exact P_dec. +apply mL_ulist. +apply mL_in; auto with zarith. +intros; apply zpmult_internal. +intros; apply zpmult_assoc. +exact zpmult_1_l. +exact zpmult_1_r. +Defined. + +End Mod. diff --git a/coqprime-8.5/Coqprime/Permutation.v b/coqprime-8.5/Coqprime/Permutation.v new file mode 100644 index 000000000..a06693f89 --- /dev/null +++ b/coqprime-8.5/Coqprime/Permutation.v @@ -0,0 +1,506 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Permutation.v + + Defintion and properties of permutations + **********************************************************************) +Require Export List. +Require Export ListAux. + +Section permutation. +Variable A : Set. + +(************************************** + Definition of permutations as sequences of adjacent transpositions + **************************************) + +Inductive permutation : list A -> list A -> Prop := + | permutation_nil : permutation nil nil + | permutation_skip : + forall (a : A) (l1 l2 : list A), + permutation l2 l1 -> permutation (a :: l2) (a :: l1) + | permutation_swap : + forall (a b : A) (l : list A), permutation (a :: b :: l) (b :: a :: l) + | permutation_trans : + forall l1 l2 l3 : list A, + permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3. +Hint Constructors permutation. + +(************************************** + Reflexivity + **************************************) + +Theorem permutation_refl : forall l : list A, permutation l l. +simple induction l. +apply permutation_nil. +intros a l1 H. +apply permutation_skip with (1 := H). +Qed. +Hint Resolve permutation_refl. + +(************************************** + Symmetry + **************************************) + +Theorem permutation_sym : + forall l m : list A, permutation l m -> permutation m l. +intros l1 l2 H'; elim H'. +apply permutation_nil. +intros a l1' l2' H1 H2. +apply permutation_skip with (1 := H2). +intros a b l1'. +apply permutation_swap. +intros l1' l2' l3' H1 H2 H3 H4. +apply permutation_trans with (1 := H4) (2 := H2). +Qed. + +(************************************** + Compatibility with list length + **************************************) + +Theorem permutation_length : + forall l m : list A, permutation l m -> length l = length m. +intros l m H'; elim H'; simpl in |- *; auto. +intros l1 l2 l3 H'0 H'1 H'2 H'3. +rewrite <- H'3; auto. +Qed. + +(************************************** + A permutation of the nil list is the nil list + **************************************) + +Theorem permutation_nil_inv : forall l : list A, permutation l nil -> l = nil. +intros l H; generalize (permutation_length _ _ H); case l; simpl in |- *; + auto. +intros; discriminate. +Qed. + +(************************************** + A permutation of the singleton list is the singleton list + **************************************) + +Let permutation_one_inv_aux : + forall l1 l2 : list A, + permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil. +intros l1 l2 H; elim H; clear H l1 l2; auto. +intros a l3 l4 H0 H1 b H2. +injection H2; intros; subst; auto. +rewrite (permutation_nil_inv _ (permutation_sym _ _ H0)); auto. +intros; discriminate. +Qed. + +Theorem permutation_one_inv : + forall (a : A) (l : list A), permutation (a :: nil) l -> l = a :: nil. +intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto. +Qed. + +(************************************** + Compatibility with the belonging + **************************************) + +Theorem permutation_in : + forall (a : A) (l m : list A), permutation l m -> In a l -> In a m. +intros a l m H; elim H; simpl in |- *; auto; intuition. +Qed. + +(************************************** + Compatibility with the append function + **************************************) + +Theorem permutation_app_comp : + forall l1 l2 l3 l4, + permutation l1 l2 -> permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4). +intros l1 l2 l3 l4 H1; generalize l3 l4; elim H1; clear H1 l1 l2 l3 l4; + simpl in |- *; auto. +intros a b l l3 l4 H. +cut (permutation (l ++ l3) (l ++ l4)); auto. +intros; apply permutation_trans with (a :: b :: l ++ l4); auto. +elim l; simpl in |- *; auto. +intros l1 l2 l3 H H0 H1 H2 l4 l5 H3. +apply permutation_trans with (l2 ++ l4); auto. +Qed. +Hint Resolve permutation_app_comp. + +(************************************** + Swap two sublists + **************************************) + +Theorem permutation_app_swap : + forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). +intros l1; elim l1; auto. +intros; rewrite <- app_nil_end; auto. +intros a l H l2. +replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l). +apply permutation_trans with (l ++ l2 ++ a :: nil); auto. +apply permutation_trans with (((a :: nil) ++ l2) ++ l); auto. +simpl in |- *; auto. +apply permutation_trans with (l ++ (a :: nil) ++ l2); auto. +apply permutation_sym; auto. +replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l). +apply permutation_app_comp; auto. +elim l2; simpl in |- *; auto. +intros a0 l0 H0. +apply permutation_trans with (a0 :: a :: l0); auto. +apply (app_ass l2 (a :: nil) l). +apply (app_ass l2 (a :: nil) l). +Qed. + +(************************************** + A transposition is a permutation + **************************************) + +Theorem permutation_transposition : + forall a b l1 l2 l3, + permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3). +intros a b l1 l2 l3. +apply permutation_app_comp; auto. +change + (permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3) + ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *. +repeat rewrite <- app_ass. +apply permutation_app_comp; auto. +apply permutation_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto. +apply permutation_app_swap; auto. +repeat rewrite app_ass. +apply permutation_app_comp; auto. +apply permutation_app_swap; auto. +Qed. + +(************************************** + An element of a list can be put on top of the list to get a permutation + **************************************) + +Theorem in_permutation_ex : + forall a l, In a l -> exists l1 : list A, permutation (a :: l1) l. +intros a l; elim l; simpl in |- *; auto. +intros H; case H; auto. +intros a0 l0 H [H0| H0]. +exists l0; rewrite H0; auto. +case H; auto; intros l1 Hl1; exists (a0 :: l1). +apply permutation_trans with (a0 :: a :: l1); auto. +Qed. + +(************************************** + A permutation of a cons can be inverted + **************************************) + +Let permutation_cons_ex_aux : + forall (a : A) (l1 l2 : list A), + permutation l1 l2 -> + forall l11 l12 : list A, + l1 = l11 ++ a :: l12 -> + exists l3 : list A, + (exists l4 : list A, + l2 = l3 ++ a :: l4 /\ permutation (l11 ++ l12) (l3 ++ l4)). +intros a l1 l2 H; elim H; clear H l1 l2. +intros l11 l12; case l11; simpl in |- *; intros; discriminate. +intros a0 l1 l2 H H0 l11 l12; case l11; simpl in |- *. +exists (nil (A:=A)); exists l1; simpl in |- *; split; auto. +injection H1; intros; subst; auto. +injection H1; intros H2 H3; rewrite <- H2; auto. +intros a1 l111 H1. +case (H0 l111 l12); auto. +injection H1; auto. +intros l3 (l4, (Hl1, Hl2)). +exists (a0 :: l3); exists l4; split; simpl in |- *; auto. +injection H1; intros; subst; auto. +injection H1; intros H2 H3; rewrite H3; auto. +intros a0 b l l11 l12; case l11; simpl in |- *. +case l12; try (intros; discriminate). +intros a1 l0 H; exists (b :: nil); exists l0; simpl in |- *; split; auto. +injection H; intros; subst; auto. +injection H; intros H1 H2 H3; rewrite H2; auto. +intros a1 l111; case l111; simpl in |- *. +intros H; exists (nil (A:=A)); exists (a0 :: l12); simpl in |- *; split; auto. +injection H; intros; subst; auto. +injection H; intros H1 H2 H3; rewrite H3; auto. +intros a2 H1111 H; exists (a2 :: a1 :: H1111); exists l12; simpl in |- *; + split; auto. +injection H; intros; subst; auto. +intros l1 l2 l3 H H0 H1 H2 l11 l12 H3. +case H0 with (1 := H3). +intros l4 (l5, (Hl1, Hl2)). +case H2 with (1 := Hl1). +intros l6 (l7, (Hl3, Hl4)). +exists l6; exists l7; split; auto. +apply permutation_trans with (1 := Hl2); auto. +Qed. + +Theorem permutation_cons_ex : + forall (a : A) (l1 l2 : list A), + permutation (a :: l1) l2 -> + exists l3 : list A, + (exists l4 : list A, l2 = l3 ++ a :: l4 /\ permutation l1 (l3 ++ l4)). +intros a l1 l2 H. +apply (permutation_cons_ex_aux a (a :: l1) l2 H nil l1); simpl in |- *; auto. +Qed. + +(************************************** + A permutation can be simply inverted if the two list starts with a cons + **************************************) + +Theorem permutation_inv : + forall (a : A) (l1 l2 : list A), + permutation (a :: l1) (a :: l2) -> permutation l1 l2. +intros a l1 l2 H; case permutation_cons_ex with (1 := H). +intros l3 (l4, (Hl1, Hl2)). +apply permutation_trans with (1 := Hl2). +generalize Hl1; case l3; simpl in |- *; auto. +intros H1; injection H1; intros H2; rewrite H2; auto. +intros a0 l5 H1; injection H1; intros H2 H3; rewrite H2; rewrite H3; auto. +apply permutation_trans with (a0 :: l4 ++ l5); auto. +apply permutation_skip; apply permutation_app_swap. +apply (permutation_app_swap (a0 :: l4) l5). +Qed. + +(************************************** + Take a list and return tle list of all pairs of an element of the + list and the remaining list + **************************************) + +Fixpoint split_one (l : list A) : list (A * list A) := + match l with + | nil => nil (A:=A * list A) + | a :: l1 => + (a, l1) + :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1) + end. + +(************************************** + The pairs of the list are a permutation + **************************************) + +Theorem split_one_permutation : + forall (a : A) (l1 l2 : list A), + In (a, l1) (split_one l2) -> permutation (a :: l1) l2. +intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto. +intros a l1 H1; case H1. +intros a l H a0 l1 [H0| H0]. +injection H0; intros H1 H2; rewrite H2; rewrite H1; auto. +generalize H H0; elim (split_one l); simpl in |- *; auto. +intros H1 H2; case H2. +intros a1 l0 H1 H2 [H3| H3]; auto. +injection H3; intros H4 H5; (rewrite <- H4; rewrite <- H5). +apply permutation_trans with (a :: fst a1 :: snd a1); auto. +apply permutation_skip. +apply H2; auto. +case a1; simpl in |- *; auto. +Qed. + +(************************************** + All elements of the list are there + **************************************) + +Theorem split_one_in_ex : + forall (a : A) (l1 : list A), + In a l1 -> exists l2 : list A, In (a, l2) (split_one l1). +intros a l1; elim l1; simpl in |- *; auto. +intros H; case H. +intros a0 l H [H0| H0]; auto. +exists l; left; subst; auto. +case H; auto. +intros x H1; exists (a0 :: x); right; auto. +apply + (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x)); + auto. +Qed. + +(************************************** + An auxillary function to generate all permutations + **************************************) + +Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} : + list (list A) := + match n with + | O => nil :: nil + | S n1 => + flat_map + (fun p : A * list A => + map (cons (fst p)) (all_permutations_aux (snd p) n1)) ( + split_one l) + end. +(************************************** + Generate all the permutations + **************************************) + +Definition all_permutations (l : list A) := all_permutations_aux l (length l). + +(************************************** + All the elements of the list are permutations + **************************************) + +Let all_permutations_aux_permutation : + forall (n : nat) (l1 l2 : list A), + n = length l2 -> In l1 (all_permutations_aux l2 n) -> permutation l1 l2. +intros n; elim n; simpl in |- *; auto. +intros l1 l2; case l2. +simpl in |- *; intros H0 [H1| H1]. +rewrite <- H1; auto. +case H1. +simpl in |- *; intros; discriminate. +intros n0 H l1 l2 H0 H1. +case in_flat_map_ex with (1 := H1). +clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2). +case in_map_inv with (1 := H2). +simpl in |- *; intros y (H3, H4). +rewrite H4; auto. +apply permutation_trans with (a1 :: l3); auto. +apply permutation_skip; auto. +apply H with (2 := H3). +apply eq_add_S. +apply trans_equal with (1 := H0). +change (length l2 = length (a1 :: l3)) in |- *. +apply permutation_length; auto. +apply permutation_sym; apply split_one_permutation; auto. +apply split_one_permutation; auto. +Qed. + +Theorem all_permutations_permutation : + forall l1 l2 : list A, In l1 (all_permutations l2) -> permutation l1 l2. +intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2); + auto. +Qed. + +(************************************** + A permutation is in the list + **************************************) + +Let permutation_all_permutations_aux : + forall (n : nat) (l1 l2 : list A), + n = length l2 -> permutation l1 l2 -> In l1 (all_permutations_aux l2 n). +intros n; elim n; simpl in |- *; auto. +intros l1 l2; case l2. +intros H H0; rewrite permutation_nil_inv with (1 := H0); auto with datatypes. +simpl in |- *; intros; discriminate. +intros n0 H l1; case l1. +intros l2 H0 H1; + rewrite permutation_nil_inv with (1 := permutation_sym _ _ H1) in H0; + discriminate. +clear l1; intros a1 l1 l2 H1 H2. +case (split_one_in_ex a1 l2); auto. +apply permutation_in with (1 := H2); auto with datatypes. +intros x H0. +apply in_flat_map with (b := (a1, x)); auto. +apply in_map; simpl in |- *. +apply H; auto. +apply eq_add_S. +apply trans_equal with (1 := H1). +change (length l2 = length (a1 :: x)) in |- *. +apply permutation_length; auto. +apply permutation_sym; apply split_one_permutation; auto. +apply permutation_inv with (a := a1). +apply permutation_trans with (1 := H2). +apply permutation_sym; apply split_one_permutation; auto. +Qed. + +Theorem permutation_all_permutations : + forall l1 l2 : list A, permutation l1 l2 -> In l1 (all_permutations l2). +intros l1 l2 H; unfold all_permutations in |- *; + apply permutation_all_permutations_aux; auto. +Qed. + +(************************************** + Permutation is decidable + **************************************) + +Definition permutation_dec : + (forall a b : A, {a = b} + {a <> b}) -> + forall l1 l2 : list A, {permutation l1 l2} + {~ permutation l1 l2}. +intros H l1 l2. +case (In_dec (list_eq_dec H) l1 (all_permutations l2)). +intros i; left; apply all_permutations_permutation; auto. +intros i; right; contradict i; apply permutation_all_permutations; auto. +Defined. + +End permutation. + +(************************************** + Hints + **************************************) + +Hint Constructors permutation. +Hint Resolve permutation_refl. +Hint Resolve permutation_app_comp. +Hint Resolve permutation_app_swap. + +(************************************** + Implicits + **************************************) + +Implicit Arguments permutation [A]. +Implicit Arguments split_one [A]. +Implicit Arguments all_permutations [A]. +Implicit Arguments permutation_dec [A]. + +(************************************** + Permutation is compatible with map + **************************************) + +Theorem permutation_map : + forall (A B : Set) (f : A -> B) l1 l2, + permutation l1 l2 -> permutation (map f l1) (map f l2). +intros A B f l1 l2 H; elim H; simpl in |- *; auto. +intros l0 l3 l4 H0 H1 H2 H3; apply permutation_trans with (2 := H3); auto. +Qed. +Hint Resolve permutation_map. + +(************************************** + Permutation of a map can be inverted + *************************************) + +Let permutation_map_ex_aux : + forall (A B : Set) (f : A -> B) l1 l2 l3, + permutation l1 l2 -> + l1 = map f l3 -> exists l4, permutation l4 l3 /\ l2 = map f l4. +intros A1 B1 f l1 l2 l3 H; generalize l3; elim H; clear H l1 l2 l3. +intros l3; case l3; simpl in |- *; auto. +intros H; exists (nil (A:=A1)); auto. +intros; discriminate. +intros a0 l1 l2 H H0 l3; case l3; simpl in |- *; auto. +intros; discriminate. +intros a1 l H1; case (H0 l); auto. +injection H1; auto. +intros l5 (H2, H3); exists (a1 :: l5); split; simpl in |- *; auto. +injection H1; intros; subst; auto. +intros a0 b l l3; case l3. +intros; discriminate. +intros a1 l0; case l0; simpl in |- *. +intros; discriminate. +intros a2 l1 H; exists (a2 :: a1 :: l1); split; simpl in |- *; auto. +injection H; intros; subst; auto. +intros l1 l2 l3 H H0 H1 H2 l0 H3. +case H0 with (1 := H3); auto. +intros l4 (HH1, HH2). +case H2 with (1 := HH2); auto. +intros l5 (HH3, HH4); exists l5; split; auto. +apply permutation_trans with (1 := HH3); auto. +Qed. + +Theorem permutation_map_ex : + forall (A B : Set) (f : A -> B) l1 l2, + permutation (map f l1) l2 -> + exists l3, permutation l3 l1 /\ l2 = map f l3. +intros A0 B f l1 l2 H; apply permutation_map_ex_aux with (l1 := map f l1); + auto. +Qed. + +(************************************** + Permutation is compatible with flat_map + **************************************) + +Theorem permutation_flat_map : + forall (A B : Set) (f : A -> list B) l1 l2, + permutation l1 l2 -> permutation (flat_map f l1) (flat_map f l2). +intros A B f l1 l2 H; elim H; simpl in |- *; auto. +intros a b l; auto. +repeat rewrite <- app_ass. +apply permutation_app_comp; auto. +intros k3 l4 l5 H0 H1 H2 H3; apply permutation_trans with (1 := H1); auto. +Qed. diff --git a/coqprime-8.5/Coqprime/Pmod.v b/coqprime-8.5/Coqprime/Pmod.v new file mode 100644 index 000000000..f64af48e3 --- /dev/null +++ b/coqprime-8.5/Coqprime/Pmod.v @@ -0,0 +1,617 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export ZArith. +Require Export ZCmisc. + +Open Local Scope positive_scope. + +Open Local Scope P_scope. + +(* [div_eucl a b] return [(q,r)] such that a = q*b + r *) +Fixpoint div_eucl (a b : positive) {struct a} : N * N := + match a with + | xH => if 1 ?< b then (0%N, 1%N) else (1%N, 0%N) + | xO a' => + let (q, r) := div_eucl a' b in + match q, r with + | N0, N0 => (0%N, 0%N) (* n'arrive jamais *) + | N0, Npos r => + if (xO r) ?< b then (0%N, Npos (xO r)) + else (1%N,PminusN (xO r) b) + | Npos q, N0 => (Npos (xO q), 0%N) + | Npos q, Npos r => + if (xO r) ?< b then (Npos (xO q), Npos (xO r)) + else (Npos (xI q),PminusN (xO r) b) + end + | xI a' => + let (q, r) := div_eucl a' b in + match q, r with + | N0, N0 => (0%N, 0%N) (* Impossible *) + | N0, Npos r => + if (xI r) ?< b then (0%N, Npos (xI r)) + else (1%N,PminusN (xI r) b) + | Npos q, N0 => if 1 ?< b then (Npos (xO q), 1%N) else (Npos (xI q), 0%N) + | Npos q, Npos r => + if (xI r) ?< b then (Npos (xO q), Npos (xI r)) + else (Npos (xI q),PminusN (xI r) b) + end + end. +Infix "/" := div_eucl : P_scope. + +Open Scope Z_scope. +Opaque Zmult. +Lemma div_eucl_spec : forall a b, + Zpos a = fst (a/b)%P * b + snd (a/b)%P + /\ snd (a/b)%P < b. +Proof with zsimpl;try apply Zlt_0_pos;try ((ring;fail) || omega). + intros a b;generalize a;clear a;induction a;simpl;zsimpl. + case IHa; destruct (a/b)%P as [q r]. + case q; case r; simpl fst; simpl snd. + rewrite Zmult_0_l; rewrite Zplus_0_r; intros HH; discriminate HH. + intros p H; rewrite H; + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + intros p H; rewrite H; + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring. + ring_simplify. + case (Zle_lt_or_eq _ _ H1); auto with zarith. + intros p p1 H; rewrite H. + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + case IHa; destruct (a/b)%P as [q r]. + case q; case r; simpl fst; simpl snd. + rewrite Zmult_0_l; rewrite Zplus_0_r; intros HH; discriminate HH. + intros p H; rewrite H; + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + intros p H; rewrite H; simpl; intros H1; split; auto. + zsimpl; ring. + intros p p1 H; rewrite H. + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + rewrite PminusN_le... + generalize H1; zsimpl; auto. + match goal with + | [|- context [ ?xx ?< b ]] => + generalize (is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end; zsimpl; simpl. + split; auto. + case (Zle_lt_or_eq 1 b); auto with zarith. + generalize (Zlt_0_pos b); auto with zarith. +Qed. +Transparent Zmult. + +(******** Definition du modulo ************) + +(* [mod a b] return [a] modulo [b] *) +Fixpoint Pmod (a b : positive) {struct a} : N := + match a with + | xH => if 1 ?< b then 1%N else 0%N + | xO a' => + let r := Pmod a' b in + match r with + | N0 => 0%N + | Npos r' => + if (xO r') ?< b then Npos (xO r') + else PminusN (xO r') b + end + | xI a' => + let r := Pmod a' b in + match r with + | N0 => if 1 ?< b then 1%N else 0%N + | Npos r' => + if (xI r') ?< b then Npos (xI r') + else PminusN (xI r') b + end + end. + +Infix "mod" := Pmod (at level 40, no associativity) : P_scope. +Open Local Scope P_scope. + +Lemma Pmod_div_eucl : forall a b, a mod b = snd (a/b). +Proof with auto. + intros a b;generalize a;clear a;induction a;simpl; + try (rewrite IHa; + assert (H1 := div_eucl_spec a b); destruct (a/b) as [q r]; + destruct q as [|q];destruct r as [|r];simpl in *; + match goal with + | [|- context [ ?xx ?< b ]] => + assert (H2 := is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end;simpl) ... + destruct H1 as [H3 H4];discriminate H3. + destruct (1 ?< b);simpl ... +Qed. + +Lemma mod1: forall a, a mod 1 = 0%N. +Proof. induction a;simpl;try rewrite IHa;trivial. Qed. + +Lemma mod_a_a_0 : forall a, a mod a = N0. +Proof. + intros a;generalize (div_eucl_spec a a);rewrite <- Pmod_div_eucl. + destruct (fst (a / a));unfold Z_of_N at 1. + rewrite Zmult_0_l;intros (H1,H2);elimtype False;omega. + assert (a<=p*a). + pattern (Zpos a) at 1;rewrite <- (Zmult_1_l a). + assert (H1:= Zlt_0_pos p);assert (H2:= Zle_0_pos a); + apply Zmult_le_compat;trivial;try omega. + destruct (a mod a)%P;auto with zarith. + unfold Z_of_N;assert (H1:= Zlt_0_pos p0);intros (H2,H3);elimtype False;omega. +Qed. + +Lemma mod_le_2r : forall (a b r: positive) (q:N), + Zpos a = b*q + r -> b <= a -> r < b -> 2*r <= a. +Proof. + intros a b r q H0 H1 H2. + assert (H3:=Zlt_0_pos a). assert (H4:=Zlt_0_pos b). assert (H5:=Zlt_0_pos r). + destruct q as [|q]. rewrite Zmult_0_r in H0. elimtype False;omega. + assert (H6:=Zlt_0_pos q). unfold Z_of_N in H0. + assert (Zpos r = a - b*q). omega. + simpl;zsimpl. pattern r at 2;rewrite H. + assert (b <= b * q). + pattern (Zpos b) at 1;rewrite <- (Zmult_1_r b). + apply Zmult_le_compat;try omega. + apply Zle_trans with (a - b * q + b). omega. + apply Zle_trans with (a - b + b);omega. +Qed. + +Lemma mod_lt : forall a b r, a mod b = Npos r -> r < b. +Proof. + intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl; + rewrite H;simpl;intros (H1,H2);omega. +Qed. + +Lemma mod_le : forall a b r, a mod b = Npos r -> r <= b. +Proof. intros a b r H;assert (H1:= mod_lt _ _ _ H);omega. Qed. + +Lemma mod_le_a : forall a b r, a mod b = r -> r <= a. +Proof. + intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl; + rewrite H;simpl;intros (H1,H2). + assert (0 <= fst (a / b) * b). + destruct (fst (a / b));simpl;auto with zarith. + auto with zarith. +Qed. + +Lemma lt_mod : forall a b, Zpos a < Zpos b -> (a mod b)%P = Npos a. +Proof. + intros a b H; rewrite Pmod_div_eucl. case (div_eucl_spec a b). + assert (0 <= snd(a/b)). destruct (snd(a/b));simpl;auto with zarith. + destruct (fst (a/b)). + unfold Z_of_N at 1;rewrite Zmult_0_l;rewrite Zplus_0_l. + destruct (snd (a/b));simpl; intros H1 H2;inversion H1;trivial. + unfold Z_of_N at 1;assert (b <= p*b). + pattern (Zpos b) at 1; rewrite <- (Zmult_1_l (Zpos b)). + assert (H1 := Zlt_0_pos p);apply Zmult_le_compat;try omega. + apply Zle_0_pos. + intros;elimtype False;omega. +Qed. + +Fixpoint gcd_log2 (a b c:positive) {struct c}: option positive := + match a mod b with + | N0 => Some b + | Npos r => + match b mod r, c with + | N0, _ => Some r + | Npos r', xH => None + | Npos r', xO c' => gcd_log2 r r' c' + | Npos r', xI c' => gcd_log2 r r' c' + end + end. + +Fixpoint egcd_log2 (a b c:positive) {struct c}: + option (Z * Z * positive) := + match a/b with + | (_, N0) => Some (0, 1, b) + | (q, Npos r) => + match b/r, c with + | (_, N0), _ => Some (1, -q, r) + | (q', Npos r'), xH => None + | (q', Npos r'), xO c' => + match egcd_log2 r r' c' with + None => None + | Some (u', v', w') => + let u := u' - v' * q' in + Some (u, v' - q * u, w') + end + | (q', Npos r'), xI c' => + match egcd_log2 r r' c' with + None => None + | Some (u', v', w') => + let u := u' - v' * q' in + Some (u, v' - q * u, w') + end + end + end. + +Lemma egcd_gcd_log2: forall c a b, + match egcd_log2 a b c, gcd_log2 a b c with + None, None => True + | Some (u,v,r), Some r' => r = r' + | _, _ => False + end. +induction c; simpl; auto; try + (intros a b; generalize (Pmod_div_eucl a b); case (a/b); simpl; + intros q r1 H; subst; case (a mod b); auto; + intros r; generalize (Pmod_div_eucl b r); case (b/r); simpl; + intros q' r1 H; subst; case (b mod r); auto; + intros r'; generalize (IHc r r'); case egcd_log2; auto; + intros ((p1,p2),p3); case gcd_log2; auto). +Qed. + +Ltac rw l := + match l with + | (?r, ?r1) => + match type of r with + True => rewrite <- r1 + | _ => rw r; rw r1 + end + | ?r => rewrite r + end. + +Lemma egcd_log2_ok: forall c a b, + match egcd_log2 a b c with + None => True + | Some (u,v,r) => u * a + v * b = r + end. +induction c; simpl; auto; + intros a b; generalize (div_eucl_spec a b); case (a/b); + simpl fst; simpl snd; intros q r1; case r1; try (intros; ring); + simpl; intros r (Hr1, Hr2); clear r1; + generalize (div_eucl_spec b r); case (b/r); + simpl fst; simpl snd; intros q' r1; case r1; + try (intros; rewrite Hr1; ring); + simpl; intros r' (Hr'1, Hr'2); clear r1; auto; + generalize (IHc r r'); case egcd_log2; auto; + intros ((u',v'),w'); case gcd_log2; auto; intros; + rw ((I, H), Hr1, Hr'1); ring. +Qed. + + +Fixpoint log2 (a:positive) : positive := + match a with + | xH => xH + | xO a => Psucc (log2 a) + | xI a => Psucc (log2 a) + end. + +Lemma gcd_log2_1: forall a c, gcd_log2 a xH c = Some xH. +Proof. destruct c;simpl;try rewrite mod1;trivial. Qed. + +Lemma log2_Zle :forall a b, Zpos a <= Zpos b -> log2 a <= log2 b. +Proof with zsimpl;try omega. + induction a;destruct b;zsimpl;intros;simpl ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (H1 := Zlt_0_pos a);elimtype False;omega. + assert (log2 a <= log2 b) ... apply IHa ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (H1 := Zlt_0_pos a);elimtype False;omega. + assert (H1 := Zlt_0_pos (log2 b)) ... + assert (H1 := Zlt_0_pos (log2 b)) ... +Qed. + +Lemma log2_1_inv : forall a, Zpos (log2 a) = 1 -> a = xH. +Proof. + destruct a;simpl;zsimpl;intros;trivial. + assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega. + assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega. +Qed. + +Lemma mod_log2 : + forall a b r:positive, a mod b = Npos r -> b <= a -> log2 r + 1 <= log2 a. +Proof. + intros; cut (log2 (xO r) <= log2 a). simpl;zsimpl;trivial. + apply log2_Zle. + replace (Zpos (xO r)) with (2 * r)%Z;trivial. + generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl;rewrite H. + rewrite Zmult_comm;intros [H1 H2];apply mod_le_2r with b (fst (a/b));trivial. +Qed. + +Lemma gcd_log2_None_aux : + forall c a b, Zpos b <= Zpos a -> log2 b <= log2 c -> + gcd_log2 a b c <> None. +Proof. + induction c;simpl;intros; + (CaseEq (a mod b);[intros Heq|intros r Heq];try (intro;discriminate)); + (CaseEq (b mod r);[intros Heq'|intros r' Heq'];try (intro;discriminate)). + apply IHc. apply mod_le with b;trivial. + generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega. + apply IHc. apply mod_le with b;trivial. + generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega. + assert (Zpos (log2 b) = 1). + assert (H1 := Zlt_0_pos (log2 b));omega. + rewrite (log2_1_inv _ H1) in Heq;rewrite mod1 in Heq;discriminate Heq. +Qed. + +Lemma gcd_log2_None : forall a b, Zpos b <= Zpos a -> gcd_log2 a b b <> None. +Proof. intros;apply gcd_log2_None_aux;auto with zarith. Qed. + +Lemma gcd_log2_Zle : + forall c1 c2 a b, log2 c1 <= log2 c2 -> + gcd_log2 a b c1 <> None -> gcd_log2 a b c2 = gcd_log2 a b c1. +Proof with zsimpl;trivial;try omega. + induction c1;destruct c2;simpl;intros; + (destruct (a mod b) as [|r];[idtac | destruct (b mod r)]) ... + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + elim H;destruct (log2 c1);trivial. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + elim H;destruct (log2 c1);trivial. + elim H0;trivial. elim H0;trivial. +Qed. + +Lemma gcd_log2_Zle_log : + forall a b c, log2 b <= log2 c -> Zpos b <= Zpos a -> + gcd_log2 a b c = gcd_log2 a b b. +Proof. + intros a b c H1 H2; apply gcd_log2_Zle; trivial. + apply gcd_log2_None; trivial. +Qed. + +Lemma gcd_log2_mod0 : + forall a b c, a mod b = N0 -> gcd_log2 a b c = Some b. +Proof. intros a b c H;destruct c;simpl;rewrite H;trivial. Qed. + + +Require Import Zwf. + +Lemma Zwf_pos : well_founded (fun x y => Zpos x < Zpos y). +Proof. + unfold well_founded. + assert (forall x a ,x = Zpos a -> Acc (fun x y : positive => x < y) a). + intros x;assert (Hacc := Zwf_well_founded 0 x);induction Hacc;intros;subst x. + constructor;intros. apply H0 with (Zpos y);trivial. + split;auto with zarith. + intros a;apply H with (Zpos a);trivial. +Qed. + +Opaque Pmod. +Lemma gcd_log2_mod : forall a b, Zpos b <= Zpos a -> + forall r, a mod b = Npos r -> gcd_log2 a b b = gcd_log2 b r r. +Proof. + intros a b;generalize a;clear a; assert (Hacc := Zwf_pos b). + induction Hacc; intros a Hle r Hmod. + rename x into b. destruct b;simpl;rewrite Hmod. + CaseEq (xI b mod r)%P;intros. rewrite gcd_log2_mod0;trivial. + assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod); + assert (H4 := mod_le _ _ _ Hmod). + rewrite (gcd_log2_Zle_log r p b);trivial. + symmetry;apply H0;trivial. + generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega. + CaseEq (xO b mod r)%P;intros. rewrite gcd_log2_mod0;trivial. + assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod); + assert (H4 := mod_le _ _ _ Hmod). + rewrite (gcd_log2_Zle_log r p b);trivial. + symmetry;apply H0;trivial. + generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega. + rewrite mod1 in Hmod;discriminate Hmod. +Qed. + +Lemma gcd_log2_xO_Zle : + forall a b, Zpos b <= Zpos a -> gcd_log2 a b (xO b) = gcd_log2 a b b. +Proof. + intros a b Hle;apply gcd_log2_Zle. + simpl;zsimpl;auto with zarith. + apply gcd_log2_None_aux;auto with zarith. +Qed. + +Lemma gcd_log2_xO_Zlt : + forall a b, Zpos a < Zpos b -> gcd_log2 a b (xO b) = gcd_log2 b a a. +Proof. + intros a b H;simpl. assert (Hlt := Zlt_0_pos a). + assert (H0 := lt_mod _ _ H). + rewrite H0;simpl. + CaseEq (b mod a)%P;intros;simpl. + symmetry;apply gcd_log2_mod0;trivial. + assert (H2 := mod_lt _ _ _ H1). + rewrite (gcd_log2_Zle_log a p b);auto with zarith. + symmetry;apply gcd_log2_mod;auto with zarith. + apply log2_Zle. + replace (Zpos p) with (Z_of_N (Npos p));trivial. + apply mod_le_a with a;trivial. +Qed. + +Lemma gcd_log2_x0 : forall a b, gcd_log2 a b (xO b) <> None. +Proof. + intros;simpl;CaseEq (a mod b)%P;intros. intro;discriminate. + CaseEq (b mod p)%P;intros. intro;discriminate. + assert (H1 := mod_le_a _ _ _ H0). unfold Z_of_N in H1. + assert (H2 := mod_le _ _ _ H0). + apply gcd_log2_None_aux. trivial. + apply log2_Zle. trivial. +Qed. + +Lemma egcd_log2_x0 : forall a b, egcd_log2 a b (xO b) <> None. +Proof. +intros a b H; generalize (egcd_gcd_log2 (xO b) a b) (gcd_log2_x0 a b); + rw H; case gcd_log2; auto. +Qed. + +Definition gcd a b := + match gcd_log2 a b (xO b) with + | Some p => p + | None => (* can not appear *) 1%positive + end. + +Definition egcd a b := + match egcd_log2 a b (xO b) with + | Some p => p + | None => (* can not appear *) (1,1,1%positive) + end. + + +Lemma gcd_mod0 : forall a b, (a mod b)%P = N0 -> gcd a b = b. +Proof. + intros a b H;unfold gcd. + pattern (gcd_log2 a b (xO b)) at 1; + rewrite (gcd_log2_mod0 _ _ (xO b) H);trivial. +Qed. + +Lemma gcd1 : forall a, gcd a xH = xH. +Proof. intros a;rewrite gcd_mod0;[trivial|apply mod1]. Qed. + +Lemma gcd_mod : forall a b r, (a mod b)%P = Npos r -> + gcd a b = gcd b r. +Proof. + intros a b r H;unfold gcd. + assert (log2 r <= log2 (xO r)). simpl;zsimpl;omega. + assert (H1 := mod_lt _ _ _ H). + pattern (gcd_log2 b r (xO r)) at 1; rewrite gcd_log2_Zle_log;auto with zarith. + destruct (Z_lt_le_dec a b) as [z|z]. + pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_xO_Zlt;trivial. + rewrite (lt_mod _ _ z) in H;inversion H. + assert (r <= b). omega. + generalize (gcd_log2_None _ _ H2). + destruct (gcd_log2 b r r);intros;trivial. + assert (log2 b <= log2 (xO b)). simpl;zsimpl;omega. + pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_Zle_log;auto with zarith. + pattern (gcd_log2 a b b) at 1;rewrite (gcd_log2_mod _ _ z _ H). + assert (r <= b). omega. + generalize (gcd_log2_None _ _ H3). + destruct (gcd_log2 b r r);intros;trivial. +Qed. + +Require Import ZArith. +Require Import Znumtheory. + +Hint Rewrite Zpos_mult times_Zmult square_Zmult Psucc_Zplus: zmisc. + +Ltac mauto := + trivial;autorewrite with zmisc;trivial;auto with zarith. + +Lemma gcd_Zis_gcd : forall a b:positive, (Zis_gcd b a (gcd b a)%P). +Proof with mauto. + intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros. + generalize (div_eucl_spec b a)... + rewrite <- (Pmod_div_eucl b a). + CaseEq (b mod a)%P;[intros Heq|intros r Heq]; intros (H1,H2). + simpl in H1;rewrite Zplus_0_r in H1. + rewrite (gcd_mod0 _ _ Heq). + constructor;mauto. + apply Zdivide_intro with (fst (b/a)%P);trivial. + rewrite (gcd_mod _ _ _ Heq). + rewrite H1;apply Zis_gcd_sym. + rewrite Zmult_comm;apply Zis_gcd_for_euclid2;simpl in *. + apply Zis_gcd_sym;auto. +Qed. + +Lemma egcd_Zis_gcd : forall a b:positive, + let (uv,w) := egcd a b in + let (u,v) := uv in + u * a + v * b = w /\ (Zis_gcd b a w). +Proof with mauto. + intros a b; unfold egcd. + generalize (egcd_log2_ok (xO b) a b) (egcd_gcd_log2 (xO b) a b) + (egcd_log2_x0 a b) (gcd_Zis_gcd b a); unfold egcd, gcd. + case egcd_log2; try (intros ((u,v),w)); case gcd_log2; + try (intros; match goal with H: False |- _ => case H end); + try (intros _ _ H1; case H1; auto; fail). + intros; subst; split; try apply Zis_gcd_sym; auto. +Qed. + +Definition Zgcd a b := + match a, b with + | Z0, _ => b + | _, Z0 => a + | Zpos a, Zneg b => Zpos (gcd a b) + | Zneg a, Zpos b => Zpos (gcd a b) + | Zpos a, Zpos b => Zpos (gcd a b) + | Zneg a, Zneg b => Zpos (gcd a b) + end. + + +Lemma Zgcd_is_gcd : forall x y, Zis_gcd x y (Zgcd x y). +Proof. + destruct x;destruct y;simpl. + apply Zis_gcd_0. + apply Zis_gcd_sym;apply Zis_gcd_0. + apply Zis_gcd_sym;apply Zis_gcd_0. + apply Zis_gcd_0. + apply gcd_Zis_gcd. + apply Zis_gcd_sym;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd. + apply Zis_gcd_0. + apply Zis_gcd_minus;simpl;apply Zis_gcd_sym;apply gcd_Zis_gcd. + apply Zis_gcd_minus;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd. +Qed. + +Definition Zegcd a b := + match a, b with + | Z0, Z0 => (0,0,0) + | Zpos _, Z0 => (1,0,a) + | Zneg _, Z0 => (-1,0,-a) + | Z0, Zpos _ => (0,1,b) + | Z0, Zneg _ => (0,-1,-b) + | Zpos a, Zneg b => + match egcd a b with (u,v,w) => (u,-v, Zpos w) end + | Zneg a, Zpos b => + match egcd a b with (u,v,w) => (-u,v, Zpos w) end + | Zpos a, Zpos b => + match egcd a b with (u,v,w) => (u,v, Zpos w) end + | Zneg a, Zneg b => + match egcd a b with (u,v,w) => (-u,-v, Zpos w) end + end. + +Lemma Zegcd_is_egcd : forall x y, + match Zegcd x y with + (u,v,w) => u * x + v * y = w /\ Zis_gcd x y w /\ 0 <= w + end. +Proof. + assert (zx0: forall x, Zneg x = -x). + simpl; auto. + assert (zx1: forall x, -(-x) = x). + intro x; case x; simpl; auto. + destruct x;destruct y;simpl; try (split; [idtac|split]); + auto; try (red; simpl; intros; discriminate); + try (rewrite zx0; apply Zis_gcd_minus; try rewrite zx1; auto; + apply Zis_gcd_minus; try rewrite zx1; simpl; auto); + try apply Zis_gcd_0; try (apply Zis_gcd_sym;apply Zis_gcd_0); + generalize (egcd_Zis_gcd p p0); case egcd; intros (u,v) w (H1, H2); + split; repeat rewrite zx0; try (rewrite <- H1; ring); auto; + (split; [idtac | red; intros; discriminate]). + apply Zis_gcd_sym; auto. + apply Zis_gcd_sym; apply Zis_gcd_minus; rw zx1; + apply Zis_gcd_sym; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_sym; auto. +Qed. diff --git a/coqprime-8.5/Coqprime/Pocklington.v b/coqprime-8.5/Coqprime/Pocklington.v new file mode 100644 index 000000000..9871cd3e6 --- /dev/null +++ b/coqprime-8.5/Coqprime/Pocklington.v @@ -0,0 +1,261 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Import ZArith. +Require Export Znumtheory. +Require Import Tactic. +Require Import ZCAux. +Require Import Zp. +Require Import FGroup. +Require Import EGroup. +Require Import Euler. + +Open Scope Z_scope. + +Theorem Pocklington: +forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> + (forall p, prime p -> (p | F1) -> exists a, 1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) -> + forall n, prime n -> (n | N) -> n mod F1 = 1. +intros N F1 R1 HF1 HR1 Neq Rec n Hn H. +assert (HN: 1 < N). +assert (0 < N - 1); auto with zarith. +rewrite Neq; auto with zarith. +apply Zlt_le_trans with (1* R1); auto with zarith. +assert (Hn1: 1 < n); auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +assert (H1: (F1 | n - 1)). +2: rewrite <- (Zmod_small 1 F1); auto with zarith. +2: case H1; intros k H1'. +2: replace n with (1 + (n - 1)); auto with zarith. +2: rewrite H1'; apply Z_mod_plus; auto with zarith. +apply Zdivide_Zpower; auto with zarith. +intros p i Hp Hi HiF1. +case (Rec p); auto. +apply Zdivide_trans with (2 := HiF1). +apply Zpower_divide; auto with zarith. +intros a (Ha1, (Ha2, Ha3)). +assert (HNn: a ^ (N - 1) mod n = 1). +apply Zdivide_mod_minus; auto with zarith. +apply Zdivide_trans with (1 := H). +apply Zmod_divide_minus; auto with zarith. +assert (~(n | a)). +intros H1; absurd (0 = 1); auto with zarith. +rewrite <- HNn; auto. +apply sym_equal; apply Zdivide_mod; auto with zarith. +apply Zdivide_trans with (1 := H1); apply Zpower_divide; auto with zarith. +assert (Hr: rel_prime a n). +apply rel_prime_sym; apply prime_rel_prime; auto. +assert (Hz: 0 < Zorder a n). +apply Zorder_power_pos; auto. +apply Zdivide_trans with (Zorder a n). +apply prime_divide_Zpower_Zdiv with (N - 1); auto with zarith. +apply Zorder_div_power; auto with zarith. +intros H1; absurd (1 < n); auto; apply Zle_not_lt; apply Zdivide_le; auto with zarith. +rewrite <- Ha3; apply Zdivide_Zgcd; auto with zarith. +apply Zmod_divide_minus; auto with zarith. +case H1; intros t Ht; rewrite Ht. +assert (Ht1: 0 <= t). +apply Zmult_le_reg_r with (Zorder a n); auto with zarith. +rewrite Zmult_0_l; rewrite <- Ht. +apply Zge_le; apply Z_div_ge0; auto with zarith. +apply Zlt_gt; apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith. +rewrite Zpower_mod; auto with zarith. +rewrite Zorder_power_is_1; auto with zarith. +rewrite Zpower_1_l; auto with zarith. +apply Zmod_small; auto with zarith. +apply Zdivide_trans with (1:= HiF1); rewrite Neq; apply Zdivide_factor_r. +apply Zorder_div; auto. +Qed. + +Theorem PocklingtonCorollary1: +forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> N < F1 * F1 -> + (forall p, prime p -> (p | F1) -> exists a, 1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) -> + prime N. +intros N F1 R1 H H1 H2 H3 H4; case (prime_dec N); intros H5; auto. +assert (HN: 1 < N). +assert (0 < N - 1); auto with zarith. +rewrite H2; auto with zarith. +apply Zlt_le_trans with (1* R1); auto with zarith. +case Zdivide_div_prime_le_square with (2:= H5); auto with zarith. +intros n (Hn, (Hn1, Hn2)). +assert (Hn3: 0 <= n). +apply Zle_trans with 2; try apply prime_ge_2; auto with zarith. +absurd (n = 1). +intros H6; contradict Hn; subst; apply not_prime_1. +rewrite <- (Zmod_small n F1); try split; auto. +apply Pocklington with (R1 := R1) (4 := H4); auto. +apply Zlt_square_mult_inv; auto with zarith. +Qed. + +Theorem PocklingtonCorollary2: +forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> + (forall p, prime p -> (p | F1) -> exists a, 1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) -> + forall n, 0 <= n -> (n | N) -> n mod F1 = 1. +intros N F1 R1 H1 H2 H3 H4 n H5; pattern n; apply prime_induction; auto. +assert (HN: 1 < N). +assert (0 < N - 1); auto with zarith. +rewrite H3; auto with zarith. +apply Zlt_le_trans with (1* R1); auto with zarith. +intros (u, Hu); contradict HN; subst; rewrite Zmult_0_r; auto with zarith. +intro H6; rewrite Zmod_small; auto with zarith. +intros p q Hp Hp1 Hp2; rewrite Zmult_mod; auto with zarith. +rewrite Pocklington with (n := p) (R1 := R1) (4 := H4); auto. +rewrite Hp1. +rewrite Zmult_1_r; rewrite Zmod_small; auto with zarith. +apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_l. +apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_r; auto. +Qed. + +Definition isSquare x := exists y, x = y * y. + +Theorem PocklingtonExtra: +forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 -> + (forall p, prime p -> (p | F1) -> exists a, 1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) -> + forall m, 1 <= m -> (forall l, 1 <= l < m -> ~((l * F1 + 1) | N)) -> + let s := (R1 / (2 * F1)) in + let r := (R1 mod (2 * F1)) in + N < (m * F1 + 1) * (2 * F1 * F1 + (r - m) * F1 + 1) -> + (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N. +intros N F1 R1 H1 H2 H3 OF1 ER1 H4 m H5 H6 s r H7 H8. +case (prime_dec N); auto; intros H9. +assert (HN: 1 < N). +assert (0 < N - 1); auto with zarith. +rewrite H3; auto with zarith. +apply Zlt_le_trans with (1* R1); auto with zarith. +case Zdivide_div_prime_le_square with N; auto. +intros X (Hx1, (Hx2, Hx3)). +assert (Hx0: 1 < X). +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +pose (c := (X / F1)). +assert(Hc1: 0 <= c); auto with zarith. +apply Zge_le; unfold c; apply Z_div_ge0; auto with zarith. +assert (Hc2: X = c * F1 + 1). +rewrite (Z_div_mod_eq X F1); auto with zarith. +eq_tac; auto. +rewrite (Zmult_comm F1); auto. +apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith. +case Zle_lt_or_eq with (1 := Hc1); clear Hc1; intros Hc1. +2: contradict Hx0; rewrite Hc2; try rewrite <- Hc1; auto with zarith. +case (Zle_or_lt m c); intros Hc3. +2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith. +2: case (H6 c); auto with zarith; rewrite <- Hc2; auto. +2: contradict Hc3; rewrite <- H5; auto with zarith. +pose (d := ((N / X) / F1)). +assert(Hd0: 0 <= N / X); try apply Z_div_pos; auto with zarith. +(* +apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith. +*) +assert(Hd1: 0 <= d); auto with zarith. +apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith. +assert (Hd2: N / X = d * F1 + 1). +rewrite (Z_div_mod_eq (N / X) F1); auto with zarith. +eq_tac; auto. +rewrite (Zmult_comm F1); auto. +apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith. +exists X; auto with zarith. +apply Zdivide_Zdiv_eq; auto with zarith. +case Zle_lt_or_eq with (1 := Hd0); clear Hd0; intros Hd0. +2: contradict HN; rewrite (Zdivide_Zdiv_eq X N); auto with zarith. +2: rewrite <- Hd0; auto with zarith. +case (Zle_lt_or_eq 1 (N / X)); auto with zarith; clear Hd0; intros Hd0. +2: contradict H9; rewrite (Zdivide_Zdiv_eq X N); auto with zarith. +2: rewrite <- Hd0; rewrite Zmult_1_r; auto with zarith. +case Zle_lt_or_eq with (1 := Hd1); clear Hd1; intros Hd1. +2: contradict Hd0; rewrite Hd2; try rewrite <- Hd1; auto with zarith. +case (Zle_or_lt m d); intros Hd3. +2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith. +2: case (H6 d); auto with zarith; rewrite <- Hd2; auto. +2: exists X; auto with zarith. +2: apply Zdivide_Zdiv_eq; auto with zarith. +2: contradict Hd3; rewrite <- H5; auto with zarith. +assert (L5: N = (c * F1 + 1) * (d * F1 + 1)). +rewrite <- Hc2; rewrite <- Hd2; apply Zdivide_Zdiv_eq; auto with zarith. +assert (L6: R1 = c * d * F1 + c + d). +apply trans_equal with ((N - 1) / F1). +rewrite H3; rewrite Zmult_comm; apply sym_equal; apply Z_div_mult; auto with zarith. +rewrite L5. +match goal with |- (?X / ?Y = ?Z) => replace X with (Z * Y) end; try ring; apply Z_div_mult; auto with zarith. +assert (L6_1: Zodd (c + d)). +case (Zeven_odd_dec (c + d)); auto; intros O1. +contradict ER1; apply Zeven_not_Zodd; rewrite L6; rewrite <- Zplus_assoc; apply Zeven_plus_Zeven; auto. +apply Zeven_mult_Zeven_r; auto. +assert (L6_2: Zeven (c * d)). +case (Zeven_odd_dec c); intros HH1. +apply Zeven_mult_Zeven_l; auto. +case (Zeven_odd_dec d); intros HH2. +apply Zeven_mult_Zeven_r; auto. +contradict L6_1; apply Zeven_not_Zodd; apply Zodd_plus_Zodd; auto. +assert ((c + d) mod (2 * F1) = r). +rewrite <- Z_mod_plus with (b := Zdiv2 (c * d)); auto with zarith. +match goal with |- ?X mod _ = _ => replace X with R1 end; auto. +rewrite L6; pattern (c * d) at 1. +rewrite Zeven_div2 with (1 := L6_2); ring. +assert (L9: c + d - r < 2 * F1). +apply Zplus_lt_reg_r with (r - m). +apply Zmult_lt_reg_r with (F1); auto with zarith. +apply Zplus_lt_reg_r with 1. +match goal with |- ?X < ?Y => + replace Y with (2 * F1 * F1 + (r - m) * F1 + 1); try ring; + replace X with ((((c + d) - m) * F1) + 1); try ring +end. +apply Zmult_lt_reg_r with (m * F1 + 1); auto with zarith. +apply Zlt_trans with (m * F1 + 0); auto with zarith. +rewrite Zplus_0_r; apply Zmult_lt_O_compat; auto with zarith. +repeat rewrite (fun x => Zmult_comm x (m * F1 + 1)). +apply Zle_lt_trans with (2 := H7). +rewrite L5. +match goal with |- ?X <= ?Y => + replace X with ((m * (c + d) - m * m ) * F1 * F1 + (c + d) * F1 + 1); try ring; + replace Y with ((c * d) * F1 * F1 + (c + d) * F1 + 1); try ring +end. +repeat apply Zplus_le_compat_r. +repeat apply Zmult_le_compat_r; auto with zarith. +assert (tmp: forall p q, 0 <= p - q -> q <= p); auto with zarith; try apply tmp. +match goal with |- _ <= ?X => + replace X with ((c - m) * (d - m)); try ring; auto with zarith +end. +assert (L10: c + d = r). +apply Zmod_closeby_eq with (2 * F1); auto with zarith. +unfold r; apply Z_mod_lt; auto with zarith. +assert (L11: 2 * s = c * d). +apply Zmult_reg_r with F1; auto with zarith. +apply trans_equal with (R1 - (c + d)). +rewrite L10; rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith. +unfold s, r; ring. +rewrite L6; ring. +case H8; intro H10. +absurd (0 < c * d); auto with zarith. +apply Zmult_lt_O_compat; auto with zarith. +case H10; exists (c - d); auto with zarith. +rewrite <- L10. +replace (8 * s) with (4 * (2 * s)); auto with zarith; try rewrite L11; ring. +Qed. + +Theorem PocklingtonExtraCorollary: +forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 -> + (forall p, prime p -> (p | F1) -> exists a, 1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) -> + let s := (R1 / (2 * F1)) in + let r := (R1 mod (2 * F1)) in + N < 2 * F1 * F1 * F1 -> (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N. +intros N F1 R1 H1 H2 H3 OF1 ER1 H4 s r H5 H6. +apply PocklingtonExtra with (6 := H4) (R1 := R1) (m := 1); auto with zarith. +apply Zlt_le_trans with (1 := H5). +match goal with |- ?X <= ?K * ((?Y + ?Z) + ?T) => + rewrite <- (Zplus_0_l X); + replace (K * ((Y + Z) + T)) with ((F1 * (Z + T) + Y + Z + T) + X);[idtac | ring] +end. +apply Zplus_le_compat_r. +case (Zle_lt_or_eq 0 r); unfold r; auto with zarith. +case (Z_mod_lt R1 (2 * F1)); auto with zarith. +intros HH; repeat ((rewrite <- (Zplus_0_r 0); apply Zplus_le_compat)); auto with zarith. +intros HH; contradict ER1; apply Zeven_not_Zodd. +rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith. +rewrite <- HH; rewrite Zplus_0_r. +rewrite <- Zmult_assoc; apply Zeven_2p. +Qed. diff --git a/coqprime-8.5/Coqprime/PocklingtonCertificat.v b/coqprime-8.5/Coqprime/PocklingtonCertificat.v new file mode 100644 index 000000000..ecf4462ed --- /dev/null +++ b/coqprime-8.5/Coqprime/PocklingtonCertificat.v @@ -0,0 +1,756 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Import List. +Require Import ZArith. +Require Import Zorder. +Require Import ZCAux. +Require Import LucasLehmer. +Require Import Pocklington. +Require Import ZCmisc. +Require Import Pmod. + +Definition dec_prime := list (positive * positive). + +Inductive singleCertif : Set := + | Proof_certif : forall N:positive, prime N -> singleCertif + | Lucas_certif : forall (n:positive) (p: Z), singleCertif + | Pock_certif : forall N a : positive, dec_prime -> positive -> singleCertif + | SPock_certif : forall N a : positive, dec_prime -> singleCertif + | Ell_certif: forall (N S: positive) (l: list (positive * positive)) + (A B x y: Z), singleCertif. + +Definition Certif := list singleCertif. + +Definition nprim sc := + match sc with + | Proof_certif n _ => n + | Lucas_certif n _ => n + | Pock_certif n _ _ _ => n + | SPock_certif n _ _ => n + | Ell_certif n _ _ _ _ _ _ => n + + end. + +Open Scope positive_scope. +Open Scope P_scope. + +Fixpoint pow (a p:positive) {struct p} : positive := + match p with + | xH => a + | xO p' =>let z := pow a p' in square z + | xI p' => let z := pow a p' in square z * a + end. + +Definition mkProd' (l:dec_prime) := + fold_right (fun (k:positive*positive) r => times (fst k) r) 1%positive l. + +Definition mkProd_pred (l:dec_prime) := + fold_right (fun (k:positive*positive) r => + if ((snd k) ?= 1)%P then r else times (pow (fst k) (Ppred (snd k))) r) + 1%positive l. + +Definition mkProd (l:dec_prime) := + fold_right (fun (k:positive*positive) r => times (pow (fst k) (snd k)) r) 1%positive l. + +(* [pow_mod a m n] return [a^m mod n] *) +Fixpoint pow_mod (a m n : positive) {struct m} : N := + match m with + | xH => (a mod n)%P + | xO m' => + let z := pow_mod a m' n in + match z with + | N0 => 0%N + | Npos z' => ((square z') mod n)%P + end + | xI m' => + let z := pow_mod a m' n in + match z with + | N0 => 0%N + | Npos z' => (((square z') * a)%P mod n)%P + end + end. + +Definition Npow_mod a m n := + match a with + | N0 => 0%N + | Npos a => pow_mod a m n + end. + +(* [fold_pow_mod a [q1,_;...;qn,_]] b = a ^(q1*...*qn) mod b *) +(* invariant a mod N = a *) +Definition fold_pow_mod a l n := + fold_left + (fun a' (qp:positive*positive) => Npow_mod a' (fst qp) n) + l a. + +Definition times_mod x y n := + match x, y with + | N0, _ => N0 + | _, N0 => N0 + | Npos x, Npos y => ((x * y)%P mod n) + end. + +Definition Npred_mod p n := + match p with + | N0 => Npos (Ppred n) + | Npos p => + if (p ?= 1) then N0 + else Npos (Ppred p) + end. + +Fixpoint all_pow_mod (prod a : N) (l:dec_prime) (n:positive) {struct l}: N*N := + match l with + | nil => (prod,a) + | (q,_) :: l => + let m := Npred_mod (fold_pow_mod a l n) n in + all_pow_mod (times_mod prod m n) (Npow_mod a q n) l n + end. + +Fixpoint pow_mod_pred (a:N) (l:dec_prime) (n:positive) {struct l} : N := + match l with + | nil => a + | (q,p)::l => + if (p ?= 1) then pow_mod_pred a l n + else + let a' := iter_pos _ (fun x => Npow_mod x q n) a (Ppred p) in + pow_mod_pred a' l n + end. + +Definition is_odd p := + match p with + | xO _ => false + | _ => true + end. + +Definition is_even p := + match p with + | xO _ => true + | _ => false + end. + +Definition check_s_r s r sqrt := + match s with + | N0 => true + | Npos p => + match (Zminus (square r) (xO (xO (xO p)))) with + | Zpos x => + let sqrt2 := square sqrt in + let sqrt12 := square (Psucc sqrt) in + if sqrt2 ?< x then x ?< sqrt12 + else false + | Zneg _ => true + | Z0 => false + end + end. + +Definition test_pock N a dec sqrt := + if (2 ?< N) then + let Nm1 := Ppred N in + let F1 := mkProd dec in + match Nm1 / F1 with + | (Npos R1, N0) => + if is_odd R1 then + if is_even F1 then + if (1 ?< a) then + let (s,r') := (R1 / (xO F1))in + match r' with + | Npos r => + let A := pow_mod_pred (pow_mod a R1 N) dec N in + match all_pow_mod 1%N A dec N with + | (Npos p, Npos aNm1) => + if (aNm1 ?= 1) then + if gcd p N ?= 1 then + if check_s_r s r sqrt then + (N ?< (times ((times ((xO F1)+r+1) F1) + r) F1) + 1) + else false + else false + else false + | _ => false + end + | _ => false + end + else false + else false + else false + | _=> false + end + else false. + +Fixpoint is_in (p : positive) (lc : Certif) {struct lc} : bool := + match lc with + | nil => false + | c :: l => if p ?= (nprim c) then true else is_in p l + end. + +Fixpoint all_in (lc : Certif) (lp : dec_prime) {struct lp} : bool := + match lp with + | nil => true + | (p,_) :: lp => + if all_in lc lp + then is_in p lc + else false + end. + +Definition gt2 n := + match n with + | Zpos p => (2 ?< p)%positive + | _ => false + end. + +Fixpoint test_Certif (lc : Certif) : bool := + match lc with + | nil => true + | (Proof_certif _ _) :: lc => test_Certif lc + | (Lucas_certif n p) :: lc => + if test_Certif lc then + if gt2 p then + match Mp p with + | Zpos n' => + if (n ?= n') then + match SS p with + | Z0 => true + | _ => false + end + else false + | _ => false + end + else false + else false + | (Pock_certif n a dec sqrt) :: lc => + if test_pock n a dec sqrt then + if all_in lc dec then test_Certif lc else false + else false +(* Shoudl be done later to do it with Z *) + | (SPock_certif n a dec) :: lc => false + | (Ell_certif _ _ _ _ _ _ _):: lc => false + end. + +Lemma pos_eq_1_spec : + forall p, + if (p ?= 1)%P then p = xH + else (1 < p). +Proof. + unfold Zlt;destruct p;simpl; auto; red;reflexivity. +Qed. + +Open Scope Z_scope. +Lemma mod_unique : forall b q1 r1 q2 r2, + 0 <= r1 < b -> + 0 <= r2 < b -> + b * q1 + r1 = b * q2 + r2 -> + q1 = q2 /\ r1 = r2. +Proof with auto with zarith. + intros b q1 r1 q2 r2 H1 H2 H3. + assert (r2 = (b * q1 + r1) -b*q2). rewrite H3;ring. + assert (b*(q2 - q1) = r1 - r2 ). rewrite H;ring. + assert (-b < r1 - r2 < b). omega. + destruct (Ztrichotomy q1 q2) as [H5 | [H5 | H5]]. + assert (q2 - q1 >= 1). omega. + assert (r1- r2 >= b). + rewrite <- H0. + pattern b at 2; replace b with (b*1). + apply Zmult_ge_compat_l; omega. ring. + elimtype False; omega. + split;trivial. rewrite H;rewrite H5;ring. + assert (r1- r2 <= -b). + rewrite <- H0. + replace (-b) with (b*(-1)); try (ring;fail). + apply Zmult_le_compat_l; omega. + elimtype False; omega. +Qed. + +Lemma Zge_0_pos : forall p:positive, p>= 0. +Proof. + intros;unfold Zge;simpl;intro;discriminate. +Qed. + +Lemma Zge_0_pos_add : forall p:positive, p+p>= 0. +Proof. + intros;simpl;apply Zge_0_pos. +Qed. + +Hint Resolve Zpower_gt_0 Zlt_0_pos Zge_0_pos Zlt_le_weak Zge_0_pos_add: zmisc. + +Hint Rewrite Zpos_mult Zpower_mult Zpower_1_r Zmod_mod Zpower_exp + times_Zmult square_Zmult Psucc_Zplus: zmisc. + +Ltac mauto := + trivial;autorewrite with zmisc;trivial;auto with zmisc zarith. + +Lemma mod_lt : forall a (b:positive), a mod b < b. +Proof. + intros a b;destruct (Z_mod_lt a b);mauto. +Qed. +Hint Resolve mod_lt : zmisc. + +Lemma Zmult_mod_l : forall (n:positive) a b, (a mod n * b) mod n = (a * b) mod n. +Proof with mauto. + intros;rewrite Zmult_mod ... rewrite (Zmult_mod a) ... +Qed. + +Lemma Zmult_mod_r : forall (n:positive) a b, (a * (b mod n)) mod n = (a * b) mod n. +Proof with mauto. + intros;rewrite Zmult_mod ... rewrite (Zmult_mod a) ... +Qed. + +Lemma Zminus_mod_l : forall (n:positive) a b, (a mod n - b) mod n = (a - b) mod n. +Proof with mauto. + intros;rewrite Zminus_mod ... rewrite (Zminus_mod a) ... +Qed. + +Lemma Zminus_mod_r : forall (n:positive) a b, (a - (b mod n)) mod n = (a - b) mod n. +Proof with mauto. + intros;rewrite Zminus_mod ... rewrite (Zminus_mod a) ... +Qed. + +Hint Rewrite Zmult_mod_l Zmult_mod_r Zminus_mod_l Zminus_mod_r : zmisc. +Hint Rewrite <- Zpower_mod : zmisc. + +Lemma Pmod_Zmod : forall a b, Z_of_N (a mod b)%P = a mod b. +Proof. + intros a b; rewrite Pmod_div_eucl. + assert (b>0). mauto. + unfold Zmod; assert (H1 := Z_div_mod a b H). + destruct (Zdiv_eucl a b) as (q2, r2). + assert (H2 := div_eucl_spec a b). + assert (Z_of_N (fst (a / b)%P) = q2 /\ Z_of_N (snd (a/b)%P) = r2). + destruct H1;destruct H2. + apply mod_unique with b;mauto. + split;mauto. + unfold Zle;destruct (snd (a / b)%P);intro;discriminate. + rewrite <- H0;symmetry;rewrite Zmult_comm;trivial. + destruct H0;auto. +Qed. +Hint Rewrite Pmod_Zmod : zmisc. + +Lemma Zpower_0 : forall p : positive, 0^p = 0. +Proof. + intros;simpl;destruct p;unfold Zpower_pos;simpl;trivial. + generalize (iter_pos Z (Z.mul 0) 1 p). + induction p;simpl;trivial. +Qed. + +Lemma pow_Zpower : forall a p, Zpos (pow a p) = a ^ p. +Proof. + induction p; mauto; simpl; mauto; rewrite IHp; mauto. +Qed. +Hint Rewrite pow_Zpower : zmisc. + +Lemma pow_mod_spec : forall n a m, Z_of_N (pow_mod a m n) = a^m mod n. +Proof. + induction m; mauto; simpl; intros; mauto. + rewrite Zmult_mod; auto with zmisc. + rewrite (Zmult_mod (a^m)(a^m)); auto with zmisc. + rewrite <- IHm; mauto. + destruct (pow_mod a m n); mauto. + rewrite (Zmult_mod (a^m)(a^m)); auto with zmisc. + rewrite <- IHm. destruct (pow_mod a m n);simpl; mauto. +Qed. +Hint Rewrite pow_mod_spec Zpower_0 : zmisc. + +Lemma Npow_mod_spec : forall a p n, Z_of_N (Npow_mod a p n) = a^p mod n. +Proof. + intros a p n;destruct a; mauto; simpl; mauto. +Qed. +Hint Rewrite Npow_mod_spec : zmisc. + +Lemma iter_Npow_mod_spec : forall n q p a, + Z_of_N (iter_pos N (fun x : N => Npow_mod x q n) a p) = a^q^p mod n. +Proof. + induction p; mauto; intros; simpl Pos.iter; mauto; repeat rewrite IHp. + rewrite (Zpower_mod ((a ^ q ^ p) ^ q ^ p));auto with zmisc. + rewrite (Zpower_mod (a ^ q ^ p)); mauto. + mauto. +Qed. +Hint Rewrite iter_Npow_mod_spec : zmisc. + +Lemma fold_pow_mod_spec : forall (n:positive) l (a:N), + Z_of_N a = a mod n -> + Z_of_N (fold_pow_mod a l n) = a^(mkProd' l) mod n. +Proof. + unfold fold_pow_mod;induction l; simpl fold_left; simpl mkProd'; + intros; mauto. + rewrite IHl; mauto. +Qed. +Hint Rewrite fold_pow_mod_spec : zmisc. + +Lemma pow_mod_pred_spec : forall (n:positive) l (a:N), + Z_of_N a = a mod n -> + Z_of_N (pow_mod_pred a l n) = a^(mkProd_pred l) mod n. +Proof. + unfold pow_mod_pred;induction l;simpl mkProd;intros; mauto. + destruct a as (q,p). + simpl mkProd_pred. + destruct (p ?= 1)%P; rewrite IHl; mauto; simpl. +Qed. +Hint Rewrite pow_mod_pred_spec : zmisc. + +Lemma mkProd_pred_mkProd : forall l, + (mkProd_pred l)*(mkProd' l) = mkProd l. +Proof. + induction l;simpl;intros; mauto. + generalize (pos_eq_1_spec (snd a)); destruct (snd a ?= 1)%P;intros. + rewrite H; mauto. + replace (mkProd_pred l * (fst a * mkProd' l)) with + (fst a *(mkProd_pred l * mkProd' l));try ring. + rewrite IHl; mauto. + rewrite Zmult_assoc. rewrite times_Zmult. + rewrite (Zmult_comm (pow (fst a) (Ppred (snd a)) * mkProd_pred l)). + rewrite Zmult_assoc. rewrite pow_Zpower. rewrite <-Ppred_Zminus;trivial. + rewrite <- Zpower_Zsucc; try omega. + replace (Zsucc (snd a - 1)) with ((snd a - 1)+1). + replace ((snd a - 1)+1) with (Zpos (snd a)); mauto. + rewrite <- IHl;repeat rewrite Zmult_assoc; mauto. + destruct (snd a - 1);trivial. + assert (1 < snd a); auto with zarith. +Qed. +Hint Rewrite mkProd_pred_mkProd : zmisc. + +Lemma lt_Zmod : forall p n, 0 <= p < n -> p mod n = p. +Proof. + intros a b H. + assert ( 0 <= a mod b < b). + apply Z_mod_lt; mauto. + destruct (mod_unique b (a/b) (a mod b) 0 a H0 H); mauto. + rewrite <- Z_div_mod_eq; mauto. +Qed. + +Lemma Npred_mod_spec : forall p n, Z_of_N p < Zpos n -> + 1 < Zpos n -> Z_of_N (Npred_mod p n) = (p - 1) mod n. +Proof. + destruct p;intros;simpl. + rewrite <- Ppred_Zminus; auto. + apply Zmod_unique with (q := -1); mauto. + assert (H1 := pos_eq_1_spec p);destruct (p?=1)%P. + rewrite H1; mauto. + unfold Z_of_N;rewrite <- Ppred_Zminus; auto. + simpl in H;symmetry; apply (lt_Zmod (p-1) n). + assert (1 < p); auto with zarith. +Qed. +Hint Rewrite Npred_mod_spec : zmisc. + +Lemma times_mod_spec : forall x y n, Z_of_N (times_mod x y n) = (x * y) mod n. +Proof. + intros; destruct x; mauto. + destruct y;simpl; mauto. +Qed. +Hint Rewrite times_mod_spec : zmisc. + +Lemma snd_all_pow_mod : + forall n l (prod a :N), + a mod (Zpos n) = a -> + Z_of_N (snd (all_pow_mod prod a l n)) = (a^(mkProd' l)) mod n. +Proof. + induction l; simpl all_pow_mod; simpl mkProd';intros; mauto. + destruct a as (q,p). + rewrite IHl; mauto. +Qed. + +Lemma fold_aux : forall a N (n:positive) l prod, + fold_left + (fun (r : Z) (k : positive * positive) => + r * (a ^(N / fst k) - 1) mod n) l (prod mod n) mod n = + fold_left + (fun (r : Z) (k : positive * positive) => + r * (a^(N / fst k) - 1)) l prod mod n. +Proof. + induction l;simpl;intros; mauto. +Qed. + +Lemma fst_all_pow_mod : + forall (n a:positive) l (R:positive) (prod A :N), + 1 < n -> + Z_of_N prod = prod mod n -> + Z_of_N A = a^R mod n -> + Z_of_N (fst (all_pow_mod prod A l n)) = + (fold_left + (fun r (k:positive*positive) => + (r * (a ^ (R* mkProd' l / (fst k)) - 1))) l prod) mod n. +Proof. + induction l;simpl;intros; mauto. + destruct a0 as (q,p);simpl. + assert (Z_of_N A = A mod n). + rewrite H1; mauto. + rewrite (IHl (R * q)%positive); mauto; mauto. + pattern (q * mkProd' l) at 2;rewrite (Zmult_comm q). + repeat rewrite Zmult_assoc. + rewrite Z_div_mult;auto with zmisc zarith. + rewrite <- fold_aux. + rewrite <- (fold_aux a (R * q * mkProd' l) n l (prod * (a ^ (R * mkProd' l) - 1)))... + assert ( ((prod * (A ^ mkProd' l - 1)) mod n) = + ((prod * ((a ^ R) ^ mkProd' l - 1)) mod n)). + repeat rewrite (Zmult_mod prod);auto with zmisc. + rewrite Zminus_mod;auto with zmisc. + rewrite (Zminus_mod ((a ^ R) ^ mkProd' l));auto with zmisc. + rewrite (Zpower_mod (a^R));auto with zmisc. rewrite H1; mauto. + rewrite H3; mauto. + rewrite H1; mauto. +Qed. + +Lemma is_odd_Zodd : forall p, is_odd p = true -> Zodd p. +Proof. + destruct p;intros;simpl;trivial;discriminate. +Qed. + +Lemma is_even_Zeven : forall p, is_even p = true -> Zeven p. +Proof. + destruct p;intros;simpl;trivial;discriminate. +Qed. + +Lemma lt_square : forall x y, 0 < x -> x < y -> x*x < y*y. +Proof. + intros; apply Zlt_trans with (x*y). + apply Zmult_lt_compat_l;trivial. + apply Zmult_lt_compat_r;trivial. omega. +Qed. + +Lemma le_square : forall x y, 0 <= x -> x <= y -> x*x <= y*y. +Proof. + intros; apply Zle_trans with (x*y). + apply Zmult_le_compat_l;trivial. + apply Zmult_le_compat_r;trivial. omega. +Qed. + +Lemma borned_square : forall x y, 0 <= x -> 0 <= y -> + x*x < y*y < (x+1)*(x+1) -> False. +Proof. + intros;destruct (Z_lt_ge_dec x y) as [z|z]. + assert (x + 1 <= y). omega. + assert (0 <= x+1). omega. + assert (H4 := le_square _ _ H3 H2). omega. + assert (H4 := le_square _ _ H0 (Zge_le _ _ z)). omega. +Qed. + +Lemma not_square : forall (sqrt:positive) n, sqrt * sqrt < n < (sqrt+1)*(sqrt + 1) -> ~(isSquare n). +Proof. + intros sqrt n H (y,H0). + destruct (Z_lt_ge_dec 0 y). + apply (borned_square sqrt y);mauto. + assert (y*y = (-y)*(-y)). ring. rewrite H1 in H0;clear H1. + apply (borned_square sqrt (-y));mauto. +Qed. + +Ltac spec_dec := + repeat match goal with + | [H:(?x ?= ?y)%P = _ |- _] => + generalize (is_eq_spec x y); + rewrite H;clear H; autorewrite with zmisc; + intro + | [H:(?x ?< ?y)%P = _ |- _] => + generalize (is_lt_spec x y); + rewrite H; clear H; autorewrite with zmisc; + intro + end. + +Ltac elimif := + match goal with + | [H: (if ?b then _ else _) = _ |- _] => + let H1 := fresh "H" in + (CaseEq b;intros H1; rewrite H1 in H; + try discriminate H); elimif + | _ => spec_dec + end. + +Lemma check_s_r_correct : forall s r sqrt, check_s_r s r sqrt = true -> + Z_of_N s = 0 \/ ~ isSquare (r * r - 8 * s). +Proof. + unfold check_s_r;intros. + destruct s as [|s]; trivial;auto. + right;CaseEq (square r - xO (xO (xO s)));[intros H1|intros p1 H1| intros p1 H1]; + rewrite H1 in H;try discriminate H. + elimif. + assert (Zpos (xO (xO (xO s))) = 8 * s). repeat rewrite Zpos_xO_add;ring. + generalizeclear H1; rewrite H2;mauto;intros. + apply (not_square sqrt). + simpl Z.of_N; rewrite H1;auto. + intros (y,Heq). + generalize H1 Heq;mauto. + unfold Z_of_N. + match goal with |- ?x = _ -> ?y = _ -> _ => + replace x with y; try ring + end. + intros Heq1;rewrite Heq1;intros Heq2. + destruct y;discriminate Heq2. +Qed. + +Lemma in_mkProd_prime_div_in : + forall p:positive, prime p -> + forall (l:dec_prime), + (forall k, In k l -> prime (fst k)) -> + Zdivide p (mkProd l) -> exists n,In (p, n) l. +Proof. + induction l;simpl mkProd; simpl In; mauto. + intros _ H1; absurd (p <= 1). + apply Zlt_not_le; apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. + apply Zdivide_le; auto with zarith. + intros. + case prime_mult with (2 := H1); auto with zarith; intros H2. + exists (snd a);left. + destruct a;simpl in *. + assert (Zpos p = Zpos p0). + rewrite (prime_div_Zpower_prime p1 p p0); mauto. + apply (H0 (p0,p1));auto. + inversion H3; auto. + destruct IHl as (n,H3); mauto. + exists n; auto. +Qed. + +Lemma gcd_Zis_gcd : forall a b:positive, (Zis_gcd b a (gcd b a)%P). +Proof. + intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros. + generalize (div_eucl_spec b a); mauto. + rewrite <- (Pmod_div_eucl b a). + CaseEq (b mod a)%P;[intros Heq|intros r Heq]; intros (H1,H2). + simpl in H1;rewrite Zplus_0_r in H1. + rewrite (gcd_mod0 _ _ Heq). + constructor;mauto. + apply Zdivide_intro with (fst (b/a)%P);trivial. + rewrite (gcd_mod _ _ _ Heq). + rewrite H1;apply Zis_gcd_sym. + rewrite Zmult_comm;apply Zis_gcd_for_euclid2;simpl in *. + apply Zis_gcd_sym;auto. +Qed. + +Lemma test_pock_correct : forall N a dec sqrt, + (forall k, In k dec -> prime (Zpos (fst k))) -> + test_pock N a dec sqrt = true -> + prime N. +Proof. + unfold test_pock;intros. + elimif. + generalize (div_eucl_spec (Ppred N) (mkProd dec)); + destruct ((Ppred N) / (mkProd dec))%P as (R1,n); mauto;intros (H2,H3). + destruct R1 as [|R1];try discriminate H0. + destruct n;try discriminate H0. + elimif. + generalize (div_eucl_spec R1 (xO (mkProd dec))); + destruct ((R1 / xO (mkProd dec))%P) as (s,r'); mauto;intros (H7,H8). + destruct r' as [|r];try discriminate H0. + generalize (fst_all_pow_mod N a dec (R1*mkProd_pred dec) 1 + (pow_mod_pred (pow_mod a R1 N) dec N)). + generalize (snd_all_pow_mod N dec 1 (pow_mod_pred (pow_mod a R1 N) dec N)). + destruct (all_pow_mod 1 (pow_mod_pred (pow_mod a R1 N) dec N) dec N) as + (prod,aNm1); mauto; simpl Z_of_N. + destruct prod as [|prod];try discriminate H0. + destruct aNm1 as [|aNm1];try discriminate H0;elimif. + simpl in H3; simpl in H2. + rewrite <- Ppred_Zminus in H2;try omega. + rewrite <- Zmult_assoc;rewrite mkProd_pred_mkProd. + intros H12;assert (a^(N-1) mod N = 1). + pattern 1 at 2;rewrite <- H9;symmetry. + simpl Z.of_N in H12. + rewrite H2; rewrite H12; mauto. + rewrite <- Zpower_mult; mauto. + clear H12. + intros H14. + match type of H14 with _ -> _ -> _ -> ?X => + assert (H12:X); try apply H14; clear H14 + end; mauto. + rewrite Zmod_small; mauto. + assert (1 < mkProd dec). + assert (H14 := Zlt_0_pos (mkProd dec)). + assert (1 <= mkProd dec); mauto. + destruct (Zle_lt_or_eq _ _ H15); mauto. + inversion H16. rewrite <- H18 in H5;discriminate H5. + simpl in H8. + assert (Z_of_N s = R1 / (2 * mkProd dec) /\ Zpos r = R1 mod (2 * mkProd dec)). + apply mod_unique with (2 * mkProd dec);auto with zarith. + revert H8; mauto. + apply Z_mod_lt; mauto. + rewrite <- Z_div_mod_eq; mauto; rewrite H7. + simpl fst; simpl snd; simpl Z_of_N. + ring. + destruct H15 as (H15,Heqr). + apply PocklingtonExtra with (F1:=mkProd dec) (R1:=R1) (m:=1); + auto with zmisc zarith. + rewrite H2; mauto. + apply is_even_Zeven; auto. + apply is_odd_Zodd; auto. + intros p; case p; clear p. + intros HH; contradict HH. + apply not_prime_0. + 2: intros p (V1, _); contradict V1; apply Zle_not_lt; red; simpl; intros; + discriminate. + intros p Hprime Hdec; exists (Zpos a);repeat split; auto with zarith. + apply Zis_gcd_gcd; auto with zarith. + change (rel_prime (a ^ ((N - 1) / p) - 1) N). + match type of H12 with _ = ?X mod _ => + apply rel_prime_div with (p := X); auto with zarith + end. + apply rel_prime_mod_rev; auto with zarith. + red. + pattern 1 at 3; rewrite <- H10; rewrite <- H12. + apply Pmod.gcd_Zis_gcd. + destruct (in_mkProd_prime_div_in _ Hprime _ H Hdec) as (q,Hin). + revert H2; mauto; intro H2. + rewrite <- H2. + match goal with |- context [fold_left ?f _ _] => + apply (ListAux.fold_left_invol_in _ _ f (fun k => Zdivide (a ^ ((N - 1) / p) - 1) k)) + with (b := (p, q)); auto with zarith + end. + rewrite <- Heqr. + generalizeclear H0; ring_simplify + (((mkProd dec + mkProd dec + r + 1) * mkProd dec + r) * mkProd dec + 1) + ((1 * mkProd dec + 1) * (2 * mkProd dec * mkProd dec + (r - 1) * mkProd dec + 1)); mauto. + rewrite <- H15;rewrite <- Heqr. + apply check_s_r_correct with sqrt; mauto. +Qed. + +Lemma is_in_In : + forall p lc, is_in p lc = true -> exists c, In c lc /\ p = nprim c. +Proof. + induction lc;simpl;try (intros;discriminate). + intros;elimif. + exists a;split;auto. inversion H0;trivial. + destruct (IHlc H) as [c [H1 H2]];exists c;auto. +Qed. + +Lemma all_in_In : + forall lc lp, all_in lc lp = true -> + forall pq, In pq lp -> exists c, In c lc /\ fst pq = nprim c. +Proof. + induction lp;simpl. intros H pq HF;elim HF. + intros;destruct a;elimif. + destruct H0;auto. + rewrite <- H0;simpl;apply is_in_In;trivial. +Qed. + +Lemma test_Certif_In_Prime : + forall lc, test_Certif lc = true -> + forall c, In c lc -> prime (nprim c). +Proof with mauto. + induction lc;simpl;intros. elim H0. + destruct H0. + subst c;destruct a;simpl... + elimif. + CaseEq (Mp p);[intros Heq|intros N' Heq|intros N' Heq];rewrite Heq in H; + try discriminate H. elimif. + CaseEq (SS p);[intros Heq'|intros N'' Heq'|intros N'' Heq'];rewrite Heq' in H; + try discriminate H. + rewrite H2;rewrite <- Heq. +apply LucasLehmer;trivial. +(destruct p; try discriminate H1). +simpl in H1; generalize (is_lt_spec 2 p); rewrite H1; auto. +elimif. +apply (test_pock_correct N a d p); mauto. + intros k Hin;destruct (all_in_In _ _ H1 _ Hin) as (c,(H2,H3)). + rewrite H3;auto. +discriminate. +discriminate. + destruct a;elimif;auto. +discriminate. +discriminate. +Qed. + +Lemma Pocklington_refl : + forall c lc, test_Certif (c::lc) = true -> prime (nprim c). +Proof. + intros c lc Heq;apply test_Certif_In_Prime with (c::lc);trivial;simpl;auto. +Qed. + diff --git a/coqprime-8.5/Coqprime/Root.v b/coqprime-8.5/Coqprime/Root.v new file mode 100644 index 000000000..2f65790d6 --- /dev/null +++ b/coqprime-8.5/Coqprime/Root.v @@ -0,0 +1,239 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + Root.v + + Proof that a polynomial has at most n roots +************************************************************************) +Require Import ZArith. +Require Import List. +Require Import UList. +Require Import Tactic. +Require Import Permutation. + +Open Scope Z_scope. + +Section Root. + +Variable A: Set. +Variable P: A -> Prop. +Variable plus mult: A -> A -> A. +Variable op: A -> A. +Variable zero one: A. + + +Let pol := list A. + +Definition toA z := +match z with + Z0 => zero +| Zpos p => iter_pos _ (plus one) zero p +| Zneg p => op (iter_pos _ (plus one) zero p) +end. + +Fixpoint eval (p: pol) (x: A) {struct p} : A := +match p with + nil => zero +| a::p1 => plus a (mult x (eval p1 x)) +end. + +Fixpoint div (p: pol) (x: A) {struct p} : pol * A := +match p with + nil => (nil, zero) +| a::nil => (nil, a) +| a::p1 => + (snd (div p1 x)::fst (div p1 x), + (plus a (mult x (snd (div p1 x))))) +end. + +Hypothesis Pzero: P zero. +Hypothesis Pplus: forall x y, P x -> P y -> P (plus x y). +Hypothesis Pmult: forall x y, P x -> P y -> P (mult x y). +Hypothesis Pop: forall x, P x -> P (op x). +Hypothesis plus_zero: forall a, P a -> plus zero a = a. +Hypothesis plus_comm: forall a b, P a -> P b -> plus a b = plus b a. +Hypothesis plus_assoc: forall a b c, P a -> P b -> P c -> plus a (plus b c) = plus (plus a b) c. +Hypothesis mult_zero: forall a, P a -> mult zero a = zero. +Hypothesis mult_comm: forall a b, P a -> P b -> mult a b = mult b a. +Hypothesis mult_assoc: forall a b c, P a -> P b -> P c -> mult a (mult b c) = mult (mult a b) c. +Hypothesis mult_plus_distr: forall a b c, P a -> P b -> P c -> mult a (plus b c) = plus (mult a b) (mult a c). +Hypothesis plus_op_zero: forall a, P a -> plus a (op a) = zero. +Hypothesis mult_integral: forall a b, P a -> P b -> mult a b = zero -> a = zero \/ b = zero. +(* Not necessary in Set just handy *) +Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}. + +Theorem eval_P: forall p a, P a -> (forall i, In i p -> P i) -> P (eval p a). +intros p a Pa; elim p; simpl; auto with datatypes. +intros a1 l1 Rec H; apply Pplus; auto. +Qed. + +Hint Resolve eval_P. + +Theorem div_P: forall p a, P a -> (forall i, In i p -> P i) -> (forall i, In i (fst (div p a)) -> P i) /\ P (snd (div p a)). +intros p a Pa; elim p; auto with datatypes. +intros a1 l1; case l1. +simpl; intuition. +intros a2 p2 Rec Hi; split. +case Rec; auto with datatypes. +intros H H1 i. +replace (In i (fst (div (a1 :: a2 :: p2) a))) with + (snd (div (a2::p2) a) = i \/ In i (fst (div (a2::p2) a))); auto. +intros [Hi1 | Hi1]; auto. +rewrite <- Hi1; auto. +change ( P (plus a1 (mult a (snd (div (a2::p2) a))))); auto with datatypes. +apply Pplus; auto with datatypes. +apply Pmult; auto with datatypes. +case Rec; auto with datatypes. +Qed. + + +Theorem div_correct: + forall p x y, P x -> P y -> (forall i, In i p -> P i) -> eval p y = plus (mult (eval (fst (div p x)) y) (plus y (op x))) (snd (div p x)). +intros p x y; elim p; simpl. +intros; rewrite mult_zero; try rewrite plus_zero; auto. +intros a l; case l; simpl; auto. +intros _ px py pa; rewrite (fun x => mult_comm x zero); repeat rewrite mult_zero; try apply plus_comm; auto. +intros a1 l1. +generalize (div_P (a1::l1) x); simpl. +match goal with |- context[fst ?A] => case A end; simpl. +intros q r Hd Rec px py pi. +assert (pr: P r). +case Hd; auto. +assert (pa1: P a1). +case Hd; auto. +assert (pey: P (eval q y)). +apply eval_P; auto. +case Hd; auto. +rewrite Rec; auto with datatypes. +rewrite (fun x y => plus_comm x (plus a y)); try rewrite <- plus_assoc; auto. +apply f_equal2 with (f := plus); auto. +repeat rewrite mult_plus_distr; auto. +repeat (rewrite (fun x y => (mult_comm (plus x y))) || rewrite mult_plus_distr); auto. +rewrite (fun x => (plus_comm x (mult y r))); auto. +repeat rewrite plus_assoc; try apply f_equal2 with (f := plus); auto. +2: repeat rewrite mult_assoc; try rewrite (fun y => mult_comm y (op x)); + repeat rewrite mult_assoc; auto. +rewrite (fun z => (plus_comm z (mult (op x) r))); auto. +repeat rewrite plus_assoc; try apply f_equal2 with (f := plus); auto. +2: apply f_equal2 with (f := mult); auto. +repeat rewrite (fun x => mult_comm x r); try rewrite <- mult_plus_distr; auto. +rewrite (plus_comm (op x)); try rewrite plus_op_zero; auto. +rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; auto. +Qed. + +Theorem div_correct_factor: + forall p a, (forall i, In i p -> P i) -> P a -> + eval p a = zero -> forall x, P x -> eval p x = (mult (eval (fst (div p a)) x) (plus x (op a))). +intros p a Hp Ha H x px. +case (div_P p a); auto; intros Hd1 Hd2. +rewrite (div_correct p a x); auto. +generalize (div_correct p a a). +rewrite plus_op_zero; try rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; try rewrite H; auto. +intros H1; rewrite <- H1; auto. +rewrite (fun x => plus_comm x zero); auto. +Qed. + +Theorem length_decrease: forall p x, p <> nil -> (length (fst (div p x)) < length p)%nat. +intros p x; elim p; simpl; auto. +intros H1; case H1; auto. +intros a l; case l; simpl; auto. +intros a1 l1. +match goal with |- context[fst ?A] => case A end; simpl; auto with zarith. +intros p1 _ H H1. +apply lt_n_S; apply H; intros; discriminate. +Qed. + +Theorem root_max: +forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) -> + (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, P x -> eval p x = zero. +intros p l; generalize p; elim l; clear l p; simpl; auto. +intros p; case p; simpl; auto. +intros a p1 _ _ _ _ H; contradict H; auto with arith. +intros a p1 Rec p; case p. +simpl; auto. +intros a1 p2 H H1 H2 H3 H4 x px. +assert (Hu: eval (a1 :: p2) a = zero); auto with datatypes. +rewrite (div_correct_factor (a1 :: p2) a); auto with datatypes. +match goal with |- mult ?X _ = _ => replace X with zero end; try apply mult_zero; auto. +apply sym_equal; apply Rec; auto with datatypes. +apply ulist_inv with (1 := H). +intros i Hi; case (div_P (a1 :: p2) a); auto. +intros x1 H5; case (mult_integral (eval (fst (div (a1 :: p2) a)) x1) (plus x1 (op a))); auto. +apply eval_P; auto. +intros i Hi; case (div_P (a1 :: p2) a); auto. +rewrite <- div_correct_factor; auto. +intros H6; case (ulist_app_inv _ (a::nil) p1 x1); simpl; auto. +left. +apply trans_equal with (plus zero x1); auto. +rewrite <- (plus_op_zero a); try rewrite <- plus_assoc; auto. +rewrite (fun x => plus_comm (op x)); try rewrite H6; try rewrite plus_comm; auto. +apply sym_equal; apply plus_zero; auto. +apply lt_n_Sm_le;apply lt_le_trans with (length (a1 :: p2)); auto with zarith. +apply length_decrease; auto with datatypes. +Qed. + +Theorem root_max_is_zero: +forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) -> + (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, (In x p) -> x = zero. +intros p l; generalize p; elim l; clear l p; simpl; auto. +intros p; case p; simpl; auto. +intros _ _ _ _ _ x H; case H. +intros a p1 _ _ _ _ H; contradict H; auto with arith. +intros a p1 Rec p; case p. +simpl; auto. +intros _ _ _ _ _ x H; case H. +simpl; intros a1 p2 H H1 H2 H3 H4 x H5. +assert (Ha1: a1 = zero). +assert (Hu: (eval (a1::p2) zero = zero)). +apply root_max with (l := a :: p1); auto. +rewrite <- Hu; simpl; rewrite mult_zero; try rewrite plus_comm; sauto. +case H5; clear H5; intros H5; subst; auto. +apply Rec with p2; auto with arith. +apply ulist_inv with (1 := H). +intros x1 Hx1. +case (In_dec A_dec zero p1); intros Hz. +case (in_permutation_ex _ zero p1); auto; intros p3 Hp3. +apply root_max with (l := a::p3); auto. +apply ulist_inv with zero. +apply ulist_perm with (a::p1); auto. +apply permutation_trans with (a:: (zero:: p3)); auto. +apply permutation_skip; auto. +apply permutation_sym; auto. +simpl; intros x2 [Hx2 | Hx2]; subst; auto. +apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes. +simpl; intros x2 [Hx2 | Hx2]; subst. +case (mult_integral x2 (eval p2 x2)); auto. +rewrite <- H3 with x2; sauto. +rewrite plus_zero; auto. +intros H6; case (ulist_app_inv _ (x2::nil) p1 x2) ; auto with datatypes. +rewrite H6; apply permutation_in with (1 := Hp3); auto with datatypes. +case (mult_integral x2 (eval p2 x2)); auto. +apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes. +apply eval_P; auto. +apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes. +rewrite <- H3 with x2; sauto; try right. +apply sym_equal; apply plus_zero; auto. +apply Pmult; auto. +apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes. +apply eval_P; auto. +apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes. +apply permutation_in with (1 := Hp3); auto with datatypes. +intros H6; case (ulist_app_inv _ (zero::nil) p3 x2) ; auto with datatypes. +simpl; apply ulist_perm with (1:= (permutation_sym _ _ _ Hp3)). +apply ulist_inv with (1 := H). +rewrite H6; auto with datatypes. +replace (length (a :: p3)) with (length (zero::p3)); auto. +rewrite permutation_length with (1 := Hp3); auto with arith. +case (mult_integral x1 (eval p2 x1)); auto. +rewrite <- H3 with x1; sauto; try right. +apply sym_equal; apply plus_zero; auto. +intros HH; case Hz; rewrite <- HH; auto. +Qed. + +End Root.
\ No newline at end of file diff --git a/coqprime-8.5/Coqprime/Tactic.v b/coqprime-8.5/Coqprime/Tactic.v new file mode 100644 index 000000000..93a244149 --- /dev/null +++ b/coqprime-8.5/Coqprime/Tactic.v @@ -0,0 +1,84 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + + +(********************************************************************** + Tactic.v + Useful tactics + **********************************************************************) + +(************************************** + A simple tactic to end a proof +**************************************) +Ltac finish := intros; auto; trivial; discriminate. + + +(************************************** + A tactic for proof by contradiction + with contradict H + H: ~A |- B gives |- A + H: ~A |- ~ B gives H: B |- A + H: A |- B gives |- ~ A + H: A |- B gives |- ~ A + H: A |- ~ B gives H: A |- ~ A +**************************************) + +Ltac contradict name := + let term := type of name in ( + match term with + (~_) => + match goal with + |- ~ _ => let x := fresh in + (intros x; case name; + generalize x; clear x name; + intro name) + | |- _ => case name; clear name + end + | _ => + match goal with + |- ~ _ => let x := fresh in + (intros x; absurd term; + [idtac | exact name]; generalize x; clear x name; + intros name) + | |- _ => generalize name; absurd term; + [idtac | exact name]; clear name + end + end). + + +(************************************** + A tactic to do case analysis keeping the equality +**************************************) + +Ltac case_eq name := + generalize (refl_equal name); pattern name at -1 in |- *; case name. + + +(************************************** + A tactic to use f_equal? theorems +**************************************) + +Ltac eq_tac := + match goal with + |- (?g _ = ?g _) => apply f_equal with (f := g) + | |- (?g ?X _ = ?g ?X _) => apply f_equal with (f := g X) + | |- (?g _ _ = ?g _ _) => apply f_equal2 with (f := g) + | |- (?g ?X ?Y _ = ?g ?X ?Y _) => apply f_equal with (f := g X Y) + | |- (?g ?X _ _ = ?g ?X _ _) => apply f_equal2 with (f := g X) + | |- (?g _ _ _ = ?g _ _ _) => apply f_equal3 with (f := g) + | |- (?g ?X ?Y ?Z _ = ?g ?X ?Y ?Z _) => apply f_equal with (f := g X Y Z) + | |- (?g ?X ?Y _ _ = ?g ?X ?Y _ _) => apply f_equal2 with (f := g X Y) + | |- (?g ?X _ _ _ = ?g ?X _ _ _) => apply f_equal3 with (f := g X) + | |- (?g _ _ _ _ _ = ?g _ _ _ _) => apply f_equal4 with (f := g) + end. + +(************************************** + A stupid tactic that tries auto also after applying sym_equal +**************************************) + +Ltac sauto := (intros; apply sym_equal; auto; fail) || auto. diff --git a/coqprime-8.5/Coqprime/UList.v b/coqprime-8.5/Coqprime/UList.v new file mode 100644 index 000000000..7b9d982ea --- /dev/null +++ b/coqprime-8.5/Coqprime/UList.v @@ -0,0 +1,286 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + UList.v + + Definition of list with distinct elements + + Definition: ulist +************************************************************************) +Require Import List. +Require Import Arith. +Require Import Permutation. +Require Import ListSet. + +Section UniqueList. +Variable A : Set. +Variable eqA_dec : forall (a b : A), ({ a = b }) + ({ a <> b }). +(* A list is unique if there is not twice the same element in the list *) + +Inductive ulist : list A -> Prop := + ulist_nil: ulist nil + | ulist_cons: forall a l, ~ In a l -> ulist l -> ulist (a :: l) . +Hint Constructors ulist . +(* Inversion theorem *) + +Theorem ulist_inv: forall a l, ulist (a :: l) -> ulist l. +intros a l H; inversion H; auto. +Qed. +(* The append of two unique list is unique if the list are distinct *) + +Theorem ulist_app: + forall l1 l2, + ulist l1 -> + ulist l2 -> (forall (a : A), In a l1 -> In a l2 -> False) -> ulist (l1 ++ l2). +intros L1; elim L1; simpl; auto. +intros a l H l2 H0 H1 H2; apply ulist_cons; simpl; auto. +red; intros H3; case in_app_or with ( 1 := H3 ); auto; intros H4. +inversion H0; auto. +apply H2 with a; auto. +apply H; auto. +apply ulist_inv with ( 1 := H0 ); auto. +intros a0 H3 H4; apply (H2 a0); auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv: + forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 -> False. +intros l1; elim l1; simpl; auto. +intros a l H l2 a0 H0 [H1|H1] H2. +inversion H0 as [|a1 l0 H3 H4 H5]; auto. +case H3; rewrite H1; auto with datatypes. +apply (H l2 a0); auto. +apply ulist_inv with ( 1 := H0 ); auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv_l: forall (l1 l2 : list A), ulist (l1 ++ l2) -> ulist l1. +intros l1; elim l1; simpl; auto. +intros a l H l2 H0. +inversion H0 as [|il1 iH1 iH2 il2 [iH4 iH5]]; apply ulist_cons; auto. +intros H5; case iH2; auto with datatypes. +apply H with l2; auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv_r: forall (l1 l2 : list A), ulist (l1 ++ l2) -> ulist l2. +intros l1; elim l1; simpl; auto. +intros a l H l2 H0; inversion H0; auto. +Qed. +(* Uniqueness is decidable *) + +Definition ulist_dec: forall l, ({ ulist l }) + ({ ~ ulist l }). +intros l; elim l; auto. +intros a l1 [H|H]; auto. +case (In_dec eqA_dec a l1); intros H2; auto. +right; red; intros H1; inversion H1; auto. +right; intros H1; case H; apply ulist_inv with ( 1 := H1 ). +Defined. +(* Uniqueness is compatible with permutation *) + +Theorem ulist_perm: + forall (l1 l2 : list A), permutation l1 l2 -> ulist l1 -> ulist l2. +intros l1 l2 H; elim H; clear H l1 l2; simpl; auto. +intros a l1 l2 H0 H1 H2; apply ulist_cons; auto. +inversion_clear H2 as [|ia il iH1 iH2 [iH3 iH4]]; auto. +intros H3; case iH1; + apply permutation_in with ( 1 := permutation_sym _ _ _ H0 ); auto. +inversion H2; auto. +intros a b L H0; apply ulist_cons; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +inversion_clear iH2 as [|ia il iH3 iH4]; auto. +intros H; case H; auto. +intros H1; case iH1; rewrite H1; simpl; auto. +apply ulist_cons; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +intros H; case iH1; simpl; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +inversion iH2; auto. +Qed. + +Theorem ulist_def: + forall l a, + In a l -> ulist l -> ~ (exists l1 , permutation l (a :: (a :: l1)) ). +intros l a H H0 [l1 H1]. +absurd (ulist (a :: (a :: l1))); auto. +intros H2; inversion_clear H2; simpl; auto with datatypes. +apply ulist_perm with ( 1 := H1 ); auto. +Qed. + +Theorem ulist_incl_permutation: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> (exists l3 , permutation l2 (l1 ++ l3) ). +intros l1; elim l1; simpl; auto. +intros l2 H H0; exists l2; simpl; auto. +intros a l H l2 H0 H1; auto. +case (in_permutation_ex _ a l2); auto with datatypes. +intros l3 Hl3. +case (H l3); auto. +apply ulist_inv with ( 1 := H0 ); auto. +intros b Hb. +assert (H2: In b (a :: l3)). +apply permutation_in with ( 1 := permutation_sym _ _ _ Hl3 ); + auto with datatypes. +simpl in H2 |-; case H2; intros H3; simpl; auto. +inversion_clear H0 as [|c lc Hk1]; auto. +case Hk1; subst a; auto. +intros l4 H4; exists l4. +apply permutation_trans with (a :: l3); auto. +apply permutation_sym; auto. +Qed. + +Theorem ulist_eq_permutation: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> length l1 = length l2 -> permutation l1 l2. +intros l1 l2 H1 H2 H3. +case (ulist_incl_permutation l1 l2); auto. +intros l3 H4. +assert (H5: l3 = @nil A). +generalize (permutation_length _ _ _ H4); rewrite length_app; rewrite H3. +rewrite plus_comm; case l3; simpl; auto. +intros a l H5; absurd (lt (length l2) (length l2)); auto with arith. +pattern (length l2) at 2; rewrite H5; auto with arith. +replace l1 with (app l1 l3); auto. +apply permutation_sym; auto. +rewrite H5; rewrite app_nil_end; auto. +Qed. + + +Theorem ulist_incl_length: + forall (l1 l2 : list A), ulist l1 -> incl l1 l2 -> le (length l1) (length l2). +intros l1 l2 H1 Hi; case ulist_incl_permutation with ( 2 := Hi ); auto. +intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto. +rewrite length_app; simpl; auto with arith. +Qed. + +Theorem ulist_incl2_permutation: + forall (l1 l2 : list A), + ulist l1 -> ulist l2 -> incl l1 l2 -> incl l2 l1 -> permutation l1 l2. +intros l1 l2 H1 H2 H3 H4. +apply ulist_eq_permutation; auto. +apply le_antisym; apply ulist_incl_length; auto. +Qed. + + +Theorem ulist_incl_length_strict: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> ~ incl l2 l1 -> lt (length l1) (length l2). +intros l1 l2 H1 Hi Hi0; case ulist_incl_permutation with ( 2 := Hi ); auto. +intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto. +rewrite length_app; simpl; auto with arith. +generalize Hl3; case l3; simpl; auto with arith. +rewrite <- app_nil_end; auto. +intros H2; case Hi0; auto. +intros a HH; apply permutation_in with ( 1 := H2 ); auto. +intros a l Hl0; (rewrite plus_comm; simpl; rewrite plus_comm; auto with arith). +Qed. + +Theorem in_inv_dec: + forall (a b : A) l, In a (cons b l) -> a = b \/ ~ a = b /\ In a l. +intros a b l H; case (eqA_dec a b); auto; intros H1. +right; split; auto; inversion H; auto. +case H1; auto. +Qed. + +Theorem in_ex_app_first: + forall (a : A) (l : list A), + In a l -> + (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) /\ ~ In a l1 ). +intros a l; elim l; clear l; auto. +intros H; case H. +intros a1 l H H1; auto. +generalize (in_inv_dec _ _ _ H1); intros [H2|[H2 H3]]. +exists (nil (A:=A)); exists l; simpl; split; auto. +subst; auto. +case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl; + split; auto. +subst; auto. +intros H4; case H4; auto. +Qed. + +Theorem ulist_inv_ulist: + forall (l : list A), + ~ ulist l -> + (exists a , + exists l1 , + exists l2 , + exists l3 , l = l1 ++ ((a :: l2) ++ (a :: l3)) /\ ulist (l1 ++ (a :: l2)) ). +intros l; elim l using list_length_ind; clear l. +intros l; case l; simpl; auto; clear l. +intros Rec H0; case H0; auto. +intros a l H H0. +case (In_dec eqA_dec a l); intros H1; auto. +case in_ex_app_first with ( 1 := H1 ); intros l1 [l2 [Hl1 Hl2]]; subst l. +case (ulist_dec l1); intros H2. +exists a; exists (@nil A); exists l1; exists l2; split; auto. +simpl; apply ulist_cons; auto. +case (H l1); auto. +rewrite length_app; auto with arith. +intros b [l3 [l4 [l5 [Hl3 Hl4]]]]; subst l1. +exists b; exists (a :: l3); exists l4; exists (l5 ++ (a :: l2)); split; simpl; + auto. +(repeat (rewrite <- ass_app; simpl)); auto. +apply ulist_cons; auto. +contradict Hl2; auto. +replace (l3 ++ (b :: (l4 ++ (b :: l5)))) with ((l3 ++ (b :: l4)) ++ (b :: l5)); + auto with datatypes. +(repeat (rewrite <- ass_app; simpl)); auto. +case (H l); auto; intros a1 [l1 [l2 [l3 [Hl3 Hl4]]]]; subst l. +exists a1; exists (a :: l1); exists l2; exists l3; split; auto. +simpl; apply ulist_cons; auto. +contradict H1. +replace (l1 ++ (a1 :: (l2 ++ (a1 :: l3)))) + with ((l1 ++ (a1 :: l2)) ++ (a1 :: l3)); auto with datatypes. +(repeat (rewrite <- ass_app; simpl)); auto. +Qed. + +Theorem incl_length_repetition: + forall (l1 l2 : list A), + incl l1 l2 -> + lt (length l2) (length l1) -> + (exists a , + exists ll1 , + exists ll2 , + exists ll3 , + l1 = ll1 ++ ((a :: ll2) ++ (a :: ll3)) /\ ulist (ll1 ++ (a :: ll2)) ). +intros l1 l2 H H0; apply ulist_inv_ulist. +intros H1; absurd (le (length l1) (length l2)); auto with arith. +apply ulist_incl_length; auto. +Qed. + +End UniqueList. +Implicit Arguments ulist [A]. +Hint Constructors ulist . + +Theorem ulist_map: + forall (A B : Set) (f : A -> B) l, + (forall x y, (In x l) -> (In y l) -> f x = f y -> x = y) -> ulist l -> ulist (map f l). +intros a b f l Hf Hl; generalize Hf; elim Hl; clear Hf; auto. +simpl; auto. +intros a1 l1 H1 H2 H3 Hf; simpl. +apply ulist_cons; auto with datatypes. +contradict H1. +case in_map_inv with ( 1 := H1 ); auto with datatypes. +intros b1 [Hb1 Hb2]. +replace a1 with b1; auto with datatypes. +Qed. + +Theorem ulist_list_prod: + forall (A : Set) (l1 l2 : list A), + ulist l1 -> ulist l2 -> ulist (list_prod l1 l2). +intros A l1 l2 Hl1 Hl2; elim Hl1; simpl; auto. +intros a l H1 H2 H3; apply ulist_app; auto. +apply ulist_map; auto. +intros x y _ _ H; inversion H; auto. +intros p Hp1 Hp2; case H1. +case in_map_inv with ( 1 := Hp1 ); intros a1 [Ha1 Ha2]; auto. +case in_list_prod_inv with ( 1 := Hp2 ); intros b1 [c1 [Hb1 [Hb2 Hb3]]]; auto. +replace a with b1; auto. +rewrite Ha2 in Hb1; injection Hb1; auto. +Qed. diff --git a/coqprime-8.5/Coqprime/ZCAux.v b/coqprime-8.5/Coqprime/ZCAux.v new file mode 100644 index 000000000..de03a2fe2 --- /dev/null +++ b/coqprime-8.5/Coqprime/ZCAux.v @@ -0,0 +1,295 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + ZCAux.v + + Auxillary functions & Theorems + **********************************************************************) + +Require Import ArithRing. +Require Export ZArith Zpow_facts. +Require Export Znumtheory. +Require Export Tactic. + +Theorem Zdivide_div_prime_le_square: forall x, 1 < x -> ~prime x -> exists p, prime p /\ (p | x) /\ p * p <= x. +intros x Hx; generalize Hx; pattern x; apply Z_lt_induction; auto with zarith. +clear x Hx; intros x Rec H H1. +case (not_prime_divide x); auto. +intros x1 ((H2, H3), H4); case (prime_dec x1); intros H5. +case (Zle_or_lt (x1 * x1) x); intros H6. +exists x1; auto. +case H4; clear H4; intros x2 H4; subst. +assert (Hx2: x2 <= x1). +case (Zle_or_lt x2 x1); auto; intros H8; contradict H6; apply Zle_not_lt. +apply Zmult_le_compat_r; auto with zarith. +case (prime_dec x2); intros H7. +exists x2; repeat (split; auto with zarith). +apply Zmult_le_compat_l; auto with zarith. +apply Zle_trans with 2%Z; try apply prime_ge_2; auto with zarith. +case (Zle_or_lt 0 x2); intros H8. +case Zle_lt_or_eq with (1 := H8); auto with zarith; clear H8; intros H8; subst; auto with zarith. +case (Zle_lt_or_eq 1 x2); auto with zarith; clear H8; intros H8; subst; auto with zarith. +case (Rec x2); try split; auto with zarith. +intros x3 (H9, (H10, H11)). +exists x3; repeat (split; auto with zarith). +contradict H; apply Zle_not_lt; auto with zarith. +apply Zle_trans with (0 * x1); auto with zarith. +case (Rec x1); try split; auto with zarith. +intros x3 (H9, (H10, H11)). +exists x3; repeat (split; auto with zarith). +apply Zdivide_trans with x1; auto with zarith. +Qed. + + +Theorem Zmult_interval: forall p q, 0 < p * q -> 1 < p -> 0 < q < p * q. +intros p q H1 H2; assert (0 < q). +case (Zle_or_lt q 0); auto; intros H3; contradict H1; apply Zle_not_lt. +rewrite <- (Zmult_0_r p). +apply Zmult_le_compat_l; auto with zarith. +split; auto. +pattern q at 1; rewrite <- (Zmult_1_l q). +apply Zmult_lt_compat_r; auto with zarith. +Qed. + +Theorem prime_induction: forall (P: Z -> Prop), P 0 -> P 1 -> (forall p q, prime p -> P q -> P (p * q)) -> forall p, 0 <= p -> P p. +intros P H H1 H2 p Hp. +generalize Hp; pattern p; apply Z_lt_induction; auto; clear p Hp. +intros p Rec Hp. +case Zle_lt_or_eq with (1 := Hp); clear Hp; intros Hp; subst; auto. +case (Zle_lt_or_eq 1 p); auto with zarith; clear Hp; intros Hp; subst; auto. +case (prime_dec p); intros H3. +rewrite <- (Zmult_1_r p); apply H2; auto. + case (Zdivide_div_prime_le_square p); auto. +intros q (Hq1, ((q2, Hq2), Hq3)); subst. +case (Zmult_interval q q2). +rewrite Zmult_comm; apply Zlt_trans with 1; auto with zarith. +apply Zlt_le_trans with 2; auto with zarith; apply prime_ge_2; auto. +intros H4 H5; rewrite Zmult_comm; apply H2; auto. +apply Rec; try split; auto with zarith. +rewrite Zmult_comm; auto. +Qed. + +Theorem div_power_max: forall p q, 1 < p -> 0 < q -> exists n, 0 <= n /\ (p ^n | q) /\ ~(p ^(1 + n) | q). +intros p q H1 H2; generalize H2; pattern q; apply Z_lt_induction; auto with zarith; clear q H2. +intros q Rec H2. +case (Zdivide_dec p q); intros H3. +case (Zdivide_Zdiv_lt_pos p q); auto with zarith; intros H4 H5. +case (Rec (Zdiv q p)); auto with zarith. +intros n (Ha1, (Ha2, Ha3)); exists (n + 1); split; auto with zarith; split. +case Ha2; intros q1 Hq; exists q1. +rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. +rewrite Zmult_assoc; rewrite <- Hq. +rewrite Zmult_comm; apply Zdivide_Zdiv_eq; auto with zarith. +intros (q1, Hu); case Ha3; exists q1. +apply Zmult_reg_r with p; auto with zarith. +rewrite (Zmult_comm (q / p)); rewrite <- Zdivide_Zdiv_eq; auto with zarith. +apply trans_equal with (1 := Hu); repeat rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +ring. +exists 0; repeat split; try rewrite Zpower_1_r; try rewrite Zpower_exp_0; auto with zarith. +Qed. + +Theorem prime_div_induction: + forall (P: Z -> Prop) n, + 0 < n -> + (P 1) -> + (forall p i, prime p -> 0 <= i -> (p^i | n) -> P (p^i)) -> + (forall p q, rel_prime p q -> P p -> P q -> P (p * q)) -> + forall m, 0 <= m -> (m | n) -> P m. +intros P n P1 Hn H H1 m Hm. +generalize Hm; pattern m; apply Z_lt_induction; auto; clear m Hm. +intros m Rec Hm H2. +case (prime_dec m); intros Hm1. +rewrite <- Zpower_1_r; apply H; auto with zarith. +rewrite Zpower_1_r; auto. +case Zle_lt_or_eq with (1 := Hm); clear Hm; intros Hm; subst. +2: contradict P1; case H2; intros; subst; auto with zarith. +case (Zle_lt_or_eq 1 m); auto with zarith; clear Hm; intros Hm; subst; auto. +case Zdivide_div_prime_le_square with m; auto. +intros p (Hp1, (Hp2, Hp3)). +case (div_power_max p m); auto with zarith. +generalize (prime_ge_2 p Hp1); auto with zarith. +intros i (Hi, (Hi1, Hi2)). +case Zle_lt_or_eq with (1 := Hi); clear Hi; intros Hi. +assert (Hpi: 0 < p ^ i). +apply Zpower_gt_0; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +rewrite (Z_div_exact_2 m (p ^ i)); auto with zarith. +apply H1; auto with zarith. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto with zarith. +apply rel_prime_sym. +apply prime_rel_prime; auto. +contradict Hi2. +case Hi1; intros; subst. +rewrite Z_div_mult in Hi2; auto with zarith. +case Hi2; intros q0 Hq0; subst. +exists q0; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. +apply H; auto with zarith. +apply Zdivide_trans with (1 := Hi1); auto. +apply Rec; auto with zarith. +split; auto with zarith. +apply Z_div_pos; auto with zarith. +apply Z_div_lt; auto with zarith. +apply Zle_ge; apply Zle_trans with p. +apply prime_ge_2; auto. +pattern p at 1; rewrite <- Zpower_1_r; apply Zpower_le_monotone; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +apply Z_div_pos; auto with zarith. +apply Zdivide_trans with (2 := H2); auto. +exists (p ^ i); apply Z_div_exact_2; auto with zarith. +apply Zdivide_mod; auto with zarith. +apply Zdivide_mod; auto with zarith. +case Hi2; rewrite <- Hi; rewrite Zplus_0_r; rewrite Zpower_1_r; auto. +Qed. + +Theorem prime_div_Zpower_prime: forall n p q, 0 <= n -> prime p -> prime q -> (p | q ^ n) -> p = q. +intros n p q Hp Hq; generalize p q Hq; pattern n; apply natlike_ind; auto; clear n p q Hp Hq. +intros p q Hp Hq; rewrite Zpower_0_r. +intros (r, H); subst. +case (Zmult_interval p r); auto; try rewrite Zmult_comm. +rewrite <- H; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. +rewrite <- H; intros H1 H2; contradict H2; auto with zarith. +intros n1 H Rec p q Hp Hq; try rewrite Zpower_Zsucc; auto with zarith; intros H1. +case prime_mult with (2 := H1); auto. +intros H2; apply prime_div_prime; auto. +Qed. + +Definition Zmodd a b := +match a with +| Z0 => 0 +| Zpos a' => + match b with + | Z0 => 0 + | Zpos _ => Zmod_POS a' b + | Zneg b' => + let r := Zmod_POS a' (Zpos b') in + match r with Z0 => 0 | _ => b + r end + end +| Zneg a' => + match b with + | Z0 => 0 + | Zpos _ => + let r := Zmod_POS a' b in + match r with Z0 => 0 | _ => b - r end + | Zneg b' => - (Zmod_POS a' (Zpos b')) + end +end. + +Theorem Zmodd_correct: forall a b, Zmodd a b = Zmod a b. +intros a b; unfold Zmod; case a; simpl; auto. +intros p; case b; simpl; auto. +intros p1; refine (Zmod_POS_correct _ _); auto. +intros p1; rewrite Zmod_POS_correct; auto. +case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. +intros p; case b; simpl; auto. +intros p1; rewrite Zmod_POS_correct; auto. +case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. +intros p1; rewrite Zmod_POS_correct; simpl; auto. +case (Zdiv_eucl_POS p (Zpos p1)); auto. +Qed. + +Theorem prime_divide_prime_eq: + forall p1 p2, prime p1 -> prime p2 -> Zdivide p1 p2 -> p1 = p2. +intros p1 p2 Hp1 Hp2 Hp3. +assert (Ha: 1 < p1). +inversion Hp1; auto. +assert (Ha1: 1 < p2). +inversion Hp2; auto. +case (Zle_lt_or_eq p1 p2); auto with zarith. +apply Zdivide_le; auto with zarith. +intros Hp4. +case (prime_div_prime p1 p2); auto with zarith. +Qed. + +Theorem Zdivide_Zpower: forall n m, 0 < n -> (forall p i, prime p -> 0 < i -> (p^i | n) -> (p^i | m)) -> (n | m). +intros n m Hn; generalize m Hn; pattern n; apply prime_induction; auto with zarith; clear n m Hn. +intros m H1; contradict H1; auto with zarith. +intros p q H Rec m H1 H2. +assert (H3: (p | m)). +rewrite <- (Zpower_1_r p); apply H2; auto with zarith; rewrite Zpower_1_r; apply Zdivide_factor_r. +case (Zmult_interval p q); auto. +apply Zlt_le_trans with 2; auto with zarith; apply prime_ge_2; auto. +case H3; intros k Hk; subst. +intros Hq Hq1. +rewrite (Zmult_comm k); apply Zmult_divide_compat_l. +apply Rec; auto. +intros p1 i Hp1 Hp2 Hp3. +case (Z_eq_dec p p1); intros Hpp1; subst. +case (H2 p1 (Zsucc i)); auto with zarith. +rewrite Zpower_Zsucc; try apply Zmult_divide_compat_l; auto with zarith. +intros q2 Hq2; exists q2. +apply Zmult_reg_r with p1. +contradict H; subst; apply not_prime_0. +rewrite Hq2; rewrite Zpower_Zsucc; try ring; auto with zarith. +apply Gauss with p. +rewrite Zmult_comm; apply H2; auto. +apply Zdivide_trans with (1:= Hp3). +apply Zdivide_factor_l. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto with zarith. +apply prime_rel_prime; auto. +contradict Hpp1; apply prime_divide_prime_eq; auto. +Qed. + +Theorem prime_divide_Zpower_Zdiv: forall m a p i, 0 <= i -> prime p -> (m | a) -> ~(m | (a/p)) -> (p^i | a) -> (p^i | m). +intros m a p i Hi Hp (k, Hk) H (l, Hl); subst. +case (Zle_lt_or_eq 0 i); auto with arith; intros Hi1; subst. +assert (Hp0: 0 < p). +apply Zlt_le_trans with 2; auto with zarith; apply prime_ge_2; auto. +case (Zdivide_dec p k); intros H1. +case H1; intros k' H2; subst. +case H; replace (k' * p * m) with ((k' * m) * p); try ring; rewrite Z_div_mult; auto with zarith. +apply Gauss with k. +exists l; rewrite Hl; ring. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto. +apply rel_prime_sym; apply prime_rel_prime; auto. +rewrite Zpower_0_r; apply Zone_divide. +Qed. + +Theorem Zle_square_mult: forall a b, 0 <= a <= b -> a * a <= b * b. +intros a b (H1, H2); apply Zle_trans with (a * b); auto with zarith. +Qed. + +Theorem Zlt_square_mult_inv: forall a b, 0 <= a -> 0 <= b -> a * a < b * b -> a < b. +intros a b H1 H2 H3; case (Zle_or_lt b a); auto; intros H4; apply Zmult_lt_reg_r with a; + contradict H3; apply Zle_not_lt; apply Zle_square_mult; auto. +Qed. + + +Theorem Zmod_closeby_eq: forall a b n, 0 <= a -> 0 <= b < n -> a - b < n -> a mod n = b -> a = b. +intros a b n H H1 H2 H3. +case (Zle_or_lt 0 (a - b)); intros H4. +case Zle_lt_or_eq with (1 := H4); clear H4; intros H4; auto with zarith. +contradict H2; apply Zle_not_lt; apply Zdivide_le; auto with zarith. +apply Zmod_divide_minus; auto with zarith. +rewrite <- (Zmod_small a n); try split; auto with zarith. +Qed. + + +Theorem Zpow_mod_pos_Zpower_pos_correct: forall a m n, 0 < n -> Zpow_mod_pos a m n = (Zpower_pos a m) mod n. +intros a m; elim m; simpl; auto. +intros p Rec n H1; rewrite xI_succ_xO; rewrite Pplus_one_succ_r; rewrite <- Pplus_diag; auto. +repeat rewrite Zpower_pos_is_exp; auto. +repeat rewrite Rec; auto. +replace (Zpower_pos a 1) with a; auto. +2: unfold Zpower_pos; simpl; auto with zarith. +repeat rewrite (fun x => (Zmult_mod x a)); auto. +rewrite (Zmult_mod (Zpower_pos a p)); auto. +case (Zpower_pos a p mod n); auto. +intros p Rec n H1; rewrite <- Pplus_diag; auto. +repeat rewrite Zpower_pos_is_exp; auto. +repeat rewrite Rec; auto. +rewrite (Zmult_mod (Zpower_pos a p)); auto. +case (Zpower_pos a p mod n); auto. +unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith. +Qed. + +Theorem Zpow_mod_Zpower_correct: forall a m n, 1 < n -> 0 <= m -> Zpow_mod a m n = (a ^ m) mod n. +intros a m n; case m; simpl; auto. +intros; apply Zpow_mod_pos_Zpower_pos_correct; auto with zarith. +Qed. diff --git a/coqprime-8.5/Coqprime/ZCmisc.v b/coqprime-8.5/Coqprime/ZCmisc.v new file mode 100644 index 000000000..c1bdacc63 --- /dev/null +++ b/coqprime-8.5/Coqprime/ZCmisc.v @@ -0,0 +1,186 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export ZArith. +Open Local Scope Z_scope. + +Coercion Zpos : positive >-> Z. +Coercion Z_of_N : N >-> Z. + +Lemma Zpos_plus : forall p q, Zpos (p + q) = p + q. +Proof. intros;trivial. Qed. + +Lemma Zpos_mult : forall p q, Zpos (p * q) = p * q. +Proof. intros;trivial. Qed. + +Lemma Zpos_xI_add : forall p, Zpos (xI p) = Zpos p + Zpos p + Zpos 1. +Proof. intros p;rewrite Zpos_xI;ring. Qed. + +Lemma Zpos_xO_add : forall p, Zpos (xO p) = Zpos p + Zpos p. +Proof. intros p;rewrite Zpos_xO;ring. Qed. + +Lemma Psucc_Zplus : forall p, Zpos (Psucc p) = p + 1. +Proof. intros p;rewrite Zpos_succ_morphism;unfold Zsucc;trivial. Qed. + +Hint Rewrite Zpos_xI_add Zpos_xO_add Pplus_carry_spec + Psucc_Zplus Zpos_plus : zmisc. + +Lemma Zlt_0_pos : forall p, 0 < Zpos p. +Proof. unfold Zlt;trivial. Qed. + + +Lemma Pminus_mask_carry_spec : forall p q, + Pminus_mask_carry p q = Pminus_mask p (Psucc q). +Proof. + intros p q;generalize q p;clear q p. + induction q;destruct p;simpl;try rewrite IHq;trivial. + destruct p;trivial. destruct p;trivial. +Qed. + +Hint Rewrite Pminus_mask_carry_spec : zmisc. + +Ltac zsimpl := autorewrite with zmisc. +Ltac CaseEq t := generalize (refl_equal t);pattern t at -1;case t. +Ltac generalizeclear H := generalize H;clear H. + +Lemma Pminus_mask_spec : + forall p q, + match Pminus_mask p q with + | IsNul => Zpos p = Zpos q + | IsPos k => Zpos p = q + k + | IsNeq => p < q + end. +Proof with zsimpl;auto with zarith. + induction p;destruct q;simpl;zsimpl; + match goal with + | [|- context [(Pminus_mask ?p1 ?q1)]] => + assert (H1 := IHp q1);destruct (Pminus_mask p1 q1) + | _ => idtac + end;simpl ... + inversion H1 ... inversion H1 ... + rewrite Psucc_Zplus in H1 ... + clear IHp;induction p;simpl ... + rewrite IHp;destruct (Pdouble_minus_one p) ... + assert (H:= Zlt_0_pos q) ... assert (H:= Zlt_0_pos q) ... +Qed. + +Definition PminusN x y := + match Pminus_mask x y with + | IsPos k => Npos k + | _ => N0 + end. + +Lemma PminusN_le : forall x y:positive, x <= y -> Z_of_N (PminusN y x) = y - x. +Proof. + intros x y Hle;unfold PminusN. + assert (H := Pminus_mask_spec y x);destruct (Pminus_mask y x). + rewrite H;unfold Z_of_N;auto with zarith. + rewrite H;unfold Z_of_N;auto with zarith. + elimtype False;omega. +Qed. + +Lemma Ppred_Zminus : forall p, 1< Zpos p -> (p-1)%Z = Ppred p. +Proof. destruct p;simpl;trivial. intros;elimtype False;omega. Qed. + + +Open Local Scope positive_scope. + +Delimit Scope P_scope with P. +Open Local Scope P_scope. + +Definition is_lt (n m : positive) := + match (n ?= m) with + | Lt => true + | _ => false + end. +Infix "?<" := is_lt (at level 70, no associativity) : P_scope. + +Lemma is_lt_spec : forall n m, if n ?< m then (n < m)%Z else (m <= n)%Z. +Proof. +intros n m; unfold is_lt, Zlt, Zle, Zcompare. +rewrite Pos.compare_antisym. +case (m ?= n); simpl; auto; intros HH; discriminate HH. +Qed. + +Definition is_eq a b := + match (a ?= b) with + | Eq => true + | _ => false + end. +Infix "?=" := is_eq (at level 70, no associativity) : P_scope. + +Lemma is_eq_refl : forall n, n ?= n = true. +Proof. intros n;unfold is_eq;rewrite Pos.compare_refl;trivial. Qed. + +Lemma is_eq_eq : forall n m, n ?= m = true -> n = m. +Proof. + unfold is_eq;intros n m H; apply Pos.compare_eq. +destruct (n ?= m)%positive;trivial;try discriminate. +Qed. + +Lemma is_eq_spec_pos : forall n m, if n ?= m then n = m else m <> n. +Proof. + intros n m; CaseEq (n ?= m);intro H. + rewrite (is_eq_eq _ _ H);trivial. + intro H1;rewrite H1 in H;rewrite is_eq_refl in H;discriminate H. +Qed. + +Lemma is_eq_spec : forall n m, if n ?= m then Zpos n = m else Zpos m <> n. +Proof. + intros n m; CaseEq (n ?= m);intro H. + rewrite (is_eq_eq _ _ H);trivial. + intro H1;inversion H1. + rewrite H2 in H;rewrite is_eq_refl in H;discriminate H. +Qed. + +Definition is_Eq a b := + match a, b with + | N0, N0 => true + | Npos a', Npos b' => a' ?= b' + | _, _ => false + end. + +Lemma is_Eq_spec : + forall n m, if is_Eq n m then Z_of_N n = m else Z_of_N m <> n. +Proof. + destruct n;destruct m;simpl;trivial;try (intro;discriminate). + apply is_eq_spec. +Qed. + +(* [times x y] return [x * y], a litle bit more efficiant *) +Fixpoint times (x y : positive) {struct y} : positive := + match x, y with + | xH, _ => y + | _, xH => x + | xO x', xO y' => xO (xO (times x' y')) + | xO x', xI y' => xO (x' + xO (times x' y')) + | xI x', xO y' => xO (y' + xO (times x' y')) + | xI x', xI y' => xI (x' + y' + xO (times x' y')) + end. + +Infix "*" := times : P_scope. + +Lemma times_Zmult : forall p q, Zpos (p * q)%P = (p * q)%Z. +Proof. + intros p q;generalize q p;clear p q. + induction q;destruct p; unfold times; try fold (times p q); + autorewrite with zmisc; try rewrite IHq; ring. +Qed. + +Fixpoint square (x:positive) : positive := + match x with + | xH => xH + | xO x => xO (xO (square x)) + | xI x => xI (xO (square x + x)) + end. + +Lemma square_Zmult : forall x, Zpos (square x) = (x * x) %Z. +Proof. + induction x as [x IHx|x IHx |];unfold square;try (fold (square x)); + autorewrite with zmisc; try rewrite IHx; ring. +Qed. diff --git a/coqprime-8.5/Coqprime/ZProgression.v b/coqprime-8.5/Coqprime/ZProgression.v new file mode 100644 index 000000000..51ce91cdc --- /dev/null +++ b/coqprime-8.5/Coqprime/ZProgression.v @@ -0,0 +1,104 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export Iterator. +Require Import ZArith. +Require Export UList. +Open Scope Z_scope. + +Theorem next_n_Z: forall n m, next_n Zsucc n m = n + Z_of_nat m. +intros n m; generalize n; elim m; clear n m. +intros n; simpl; auto with zarith. +intros m H n. +replace (n + Z_of_nat (S m)) with (Zsucc n + Z_of_nat m); auto with zarith. +rewrite <- H; auto with zarith. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_end: + forall n m, + progression Zsucc n (S m) = + app (progression Zsucc n m) (cons (n + Z_of_nat m) nil). +intros n m; generalize n; elim m; clear n m. +simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith. +intros m1 Hm1 n1. +apply trans_equal with (cons n1 (progression Zsucc (Zsucc n1) (S m1))); auto. +rewrite Hm1. +replace (Zsucc n1 + Z_of_nat m1) with (n1 + Z_of_nat (S m1)); auto with zarith. +replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_pred_end: + forall n m, + progression Zpred n (S m) = + app (progression Zpred n m) (cons (n - Z_of_nat m) nil). +intros n m; generalize n; elim m; clear n m. +simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith. +intros m1 Hm1 n1. +apply trans_equal with (cons n1 (progression Zpred (Zpred n1) (S m1))); auto. +rewrite Hm1. +replace (Zpred n1 - Z_of_nat m1) with (n1 - Z_of_nat (S m1)); auto with zarith. +replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_opp: + forall n m, + rev (progression Zsucc n m) = progression Zpred (n + Z_of_nat (pred m)) m. +intros n m; generalize n; elim m; clear n m. +simpl; auto. +intros m Hm n. +rewrite (Zprogression_end n); auto. +rewrite distr_rev. +rewrite Hm; simpl; auto. +case m. +simpl; auto. +intros m1; + replace (n + Z_of_nat (pred (S m1))) with (Zpred (n + Z_of_nat (S m1))); auto. +rewrite inj_S; simpl; (unfold Zpred; unfold Zsucc); auto with zarith. +Qed. + +Theorem Zprogression_le_init: + forall n m p, In p (progression Zsucc n m) -> (n <= p). +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with zarith. +generalize (H _ _ H1); auto with zarith. +Qed. + +Theorem Zprogression_le_end: + forall n m p, In p (progression Zsucc n m) -> (p < n + Z_of_nat m). +intros n m; generalize n; elim m; clear n m; auto. +intros; contradiction. +intros m H n p H1; simpl in H1 |-; case H1; clear H1; intros H1; + auto with zarith. +subst n; auto with zarith. +apply Zle_lt_trans with (p + 0); auto with zarith. +apply Zplus_lt_compat_l; red; simpl; auto with zarith. +apply Zlt_le_trans with (Zsucc n + Z_of_nat m); auto with zarith. +rewrite inj_S; rewrite Zplus_succ_comm; auto with zarith. +Qed. + +Theorem ulist_Zprogression: forall a n, ulist (progression Zsucc a n). +intros a n; generalize a; elim n; clear a n; simpl; auto with zarith. +intros n H1 a; apply ulist_cons; auto. +intros H2; absurd (Zsucc a <= a); auto with zarith. +apply Zprogression_le_init with ( 1 := H2 ). +Qed. + +Theorem in_Zprogression: + forall a b n, ( a <= b < a + Z_of_nat n ) -> In b (progression Zsucc a n). +intros a b n; generalize a b; elim n; clear a b n; auto with zarith. +simpl; auto with zarith. +intros n H a b. +replace (a + Z_of_nat (S n)) with (Zsucc a + Z_of_nat n); auto with zarith. +intros [H1 H2]; simpl; auto with zarith. +case (Zle_lt_or_eq _ _ H1); auto with zarith. +rewrite inj_S; auto with zarith. +Qed. diff --git a/coqprime-8.5/Coqprime/ZSum.v b/coqprime-8.5/Coqprime/ZSum.v new file mode 100644 index 000000000..3a7f14065 --- /dev/null +++ b/coqprime-8.5/Coqprime/ZSum.v @@ -0,0 +1,335 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + Summation.v from Z to Z + *********************************************************************) +Require Import Arith. +Require Import ArithRing. +Require Import ListAux. +Require Import ZArith. +Require Import Iterator. +Require Import ZProgression. + + +Open Scope Z_scope. +(* Iterated Sum *) + +Definition Zsum := + fun n m f => + if Zle_bool n m + then iter 0 f Zplus (progression Zsucc n (Zabs_nat ((1 + m) - n))) + else iter 0 f Zplus (progression Zpred n (Zabs_nat ((1 + n) - m))). +Hint Unfold Zsum . + +Lemma Zsum_nn: forall n f, Zsum n n f = f n. +intros n f; unfold Zsum; rewrite Zle_bool_refl. +replace ((1 + n) - n) with 1; auto with zarith. +simpl; ring. +Qed. + +Theorem permutation_rev: forall (A:Set) (l : list A), permutation (rev l) l. +intros a l; elim l; simpl; auto. +intros a1 l1 Hl1. +apply permutation_trans with (cons a1 (rev l1)); auto. +change (permutation (rev l1 ++ (a1 :: nil)) (app (cons a1 nil) (rev l1))); auto. +Qed. + +Lemma Zsum_swap: forall (n m : Z) (f : Z -> Z), Zsum n m f = Zsum m n f. +intros n m f; unfold Zsum. +generalize (Zle_cases n m) (Zle_cases m n); case (Zle_bool n m); + case (Zle_bool m n); auto with arith. +intros; replace n with m; auto with zarith. +3:intros H1 H2; contradict H2; auto with zarith. +intros H1 H2; apply iter_permutation; auto with zarith. +apply permutation_trans + with (rev (progression Zsucc n (Zabs_nat ((1 + m) - n)))). +apply permutation_sym; apply permutation_rev. +rewrite Zprogression_opp; auto with zarith. +replace (n + Z_of_nat (pred (Zabs_nat ((1 + m) - n)))) with m; auto. +replace (Zabs_nat ((1 + m) - n)) with (S (Zabs_nat (m - n))); auto with zarith. +simpl. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +replace ((1 + m) - n) with (1 + (m - n)); auto with zarith. +cut (0 <= m - n); auto with zarith; unfold Zabs_nat. +case (m - n); auto with zarith. +intros p; case p; simpl; auto with zarith. +intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI; + rewrite nat_of_P_succ_morphism. +simpl; repeat rewrite plus_0_r. +repeat rewrite <- plus_n_Sm; simpl; auto. +intros p H3; contradict H3; auto with zarith. +intros H1 H2; apply iter_permutation; auto with zarith. +apply permutation_trans + with (rev (progression Zsucc m (Zabs_nat ((1 + n) - m)))). +rewrite Zprogression_opp; auto with zarith. +replace (m + Z_of_nat (pred (Zabs_nat ((1 + n) - m)))) with n; auto. +replace (Zabs_nat ((1 + n) - m)) with (S (Zabs_nat (n - m))); auto with zarith. +simpl. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +replace ((1 + n) - m) with (1 + (n - m)); auto with zarith. +cut (0 <= n - m); auto with zarith; unfold Zabs_nat. +case (n - m); auto with zarith. +intros p; case p; simpl; auto with zarith. +intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI; + rewrite nat_of_P_succ_morphism. +simpl; repeat rewrite plus_0_r. +repeat rewrite <- plus_n_Sm; simpl; auto. +intros p H3; contradict H3; auto with zarith. +apply permutation_rev. +Qed. + +Lemma Zsum_split_up: + forall (n m p : Z) (f : Z -> Z), + ( n <= m < p ) -> Zsum n p f = Zsum n m f + Zsum (m + 1) p f. +intros n m p f [H H0]. +case (Zle_lt_or_eq _ _ H); clear H; intros H. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +assert (H1: n < p). +apply Zlt_trans with ( 1 := H ); auto with zarith. +assert (H2: m < 1 + p). +apply Zlt_trans with ( 1 := H0 ); auto with zarith. +assert (H3: n < 1 + m). +apply Zlt_trans with ( 1 := H ); auto with zarith. +assert (H4: n < 1 + p). +apply Zlt_trans with ( 1 := H1 ); auto with zarith. +replace (Zabs_nat ((1 + p) - (m + 1))) + with (minus (Zabs_nat ((1 + p) - n)) (Zabs_nat ((1 + m) - n))). +apply iter_progression_app; auto with zarith. +apply inj_le_rev. +(repeat rewrite inj_Zabs_nat); auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +rewrite next_n_Z; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply inj_eq_rev; auto with zarith. +rewrite inj_minus1; auto with zarith. +(repeat rewrite inj_Zabs_nat); auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +apply inj_le_rev. +(repeat rewrite inj_Zabs_nat); auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +subst m. +rewrite Zsum_nn; auto with zarith. +unfold Zsum; generalize (Zle_cases n p); generalize (Zle_cases (n + 1) p); + case (Zle_bool n p); case (Zle_bool (n + 1) p); auto with zarith. +intros H1 H2. +replace (Zabs_nat ((1 + p) - n)) with (S (Zabs_nat (p - n))); auto with zarith. +replace (n + 1) with (Zsucc n); auto with zarith. +replace ((1 + p) - Zsucc n) with (p - n); auto with zarith. +apply inj_eq_rev; auto with zarith. +rewrite inj_S; (repeat rewrite inj_Zabs_nat); auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +Qed. + +Lemma Zsum_S_left: + forall (n m : Z) (f : Z -> Z), n < m -> Zsum n m f = f n + Zsum (n + 1) m f. +intros n m f H; rewrite (Zsum_split_up n n m f); auto with zarith. +rewrite Zsum_nn; auto with zarith. +Qed. + +Lemma Zsum_S_right: + forall (n m : Z) (f : Z -> Z), + n <= m -> Zsum n (m + 1) f = Zsum n m f + f (m + 1). +intros n m f H; rewrite (Zsum_split_up n m (m + 1) f); auto with zarith. +rewrite Zsum_nn; auto with zarith. +Qed. + +Lemma Zsum_split_down: + forall (n m p : Z) (f : Z -> Z), + ( p < m <= n ) -> Zsum n p f = Zsum n m f + Zsum (m - 1) p f. +intros n m p f [H H0]. +case (Zle_lt_or_eq p (m - 1)); auto with zarith; intros H1. +pattern m at 1; replace m with ((m - 1) + 1); auto with zarith. +repeat rewrite (Zsum_swap n). +rewrite (Zsum_swap (m - 1)). +rewrite Zplus_comm. +apply Zsum_split_up; auto with zarith. +subst p. +repeat rewrite (Zsum_swap n). +rewrite Zsum_nn. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +replace (Zabs_nat ((1 + n) - (m - 1))) with (S (Zabs_nat (n - (m - 1)))). +rewrite Zplus_comm. +replace (Zabs_nat ((1 + n) - m)) with (Zabs_nat (n - (m - 1))); auto with zarith. +pattern m at 4; replace m with (Zsucc (m - 1)); auto with zarith. +apply f_equal with ( f := Zabs_nat ); auto with zarith. +apply inj_eq_rev; auto with zarith. +rewrite inj_S. +(repeat rewrite inj_Zabs_nat); auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +Qed. + + +Lemma Zsum_ext: + forall (n m : Z) (f g : Z -> Z), + n <= m -> + (forall (x : Z), ( n <= x <= m ) -> f x = g x) -> Zsum n m f = Zsum n m g. +intros n m f g HH H. +unfold Zsum; auto. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +apply iter_ext; auto with zarith. +intros a H1; apply H; auto; split. +apply Zprogression_le_init with ( 1 := H1 ). +cut (a < Zsucc m); auto with zarith. +replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +Qed. + +Lemma Zsum_add: + forall (n m : Z) (f g : Z -> Z), + Zsum n m f + Zsum n m g = Zsum n m (fun (i : Z) => f i + g i). +intros n m f g; unfold Zsum; case (Zle_bool n m); apply iter_comp; + auto with zarith. +Qed. + +Lemma Zsum_times: + forall n m x f, x * Zsum n m f = Zsum n m (fun i=> x * f i). +intros n m x f. +unfold Zsum. case (Zle_bool n m); intros; apply iter_comp_const with (k := (fun y : Z => x * y)); auto with zarith. +Qed. + +Lemma inv_Zsum: + forall (P : Z -> Prop) (n m : Z) (f : Z -> Z), + n <= m -> + P 0 -> + (forall (a b : Z), P a -> P b -> P (a + b)) -> + (forall (x : Z), ( n <= x <= m ) -> P (f x)) -> P (Zsum n m f). +intros P n m f HH H H0 H1. +unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith; apply iter_inv; auto. +intros x H3; apply H1; auto; split. +apply Zprogression_le_init with ( 1 := H3 ). +cut (x < Zsucc m); auto with zarith. +replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +(repeat rewrite Zabs_eq); auto with zarith. +Qed. + + +Lemma Zsum_pred: + forall (n m : Z) (f : Z -> Z), + Zsum n m f = Zsum (n + 1) (m + 1) (fun (i : Z) => f (Zpred i)). +intros n m f. +unfold Zsum. +generalize (Zle_cases n m); generalize (Zle_cases (n + 1) (m + 1)); + case (Zle_bool n m); case (Zle_bool (n + 1) (m + 1)); auto with zarith. +replace ((1 + (m + 1)) - (n + 1)) with ((1 + m) - n); auto with zarith. +intros H1 H2; cut (exists c , c = Zabs_nat ((1 + m) - n) ). +intros [c H3]; rewrite <- H3. +generalize n; elim c; auto with zarith; clear H1 H2 H3 c n. +intros c H n; simpl; eq_tac; auto with zarith. +eq_tac; unfold Zpred; auto with zarith. +replace (Zsucc (n + 1)) with (Zsucc n + 1); auto with zarith. +exists (Zabs_nat ((1 + m) - n)); auto. +replace ((1 + (n + 1)) - (m + 1)) with ((1 + n) - m); auto with zarith. +intros H1 H2; cut (exists c , c = Zabs_nat ((1 + n) - m) ). +intros [c H3]; rewrite <- H3. +generalize n; elim c; auto with zarith; clear H1 H2 H3 c n. +intros c H n; simpl; (eq_tac; auto with zarith). +eq_tac; unfold Zpred; auto with zarith. +replace (Zpred (n + 1)) with (Zpred n + 1); auto with zarith. +unfold Zpred; auto with zarith. +exists (Zabs_nat ((1 + n) - m)); auto. +Qed. + +Theorem Zsum_c: + forall (c p q : Z), p <= q -> Zsum p q (fun x => c) = ((1 + q) - p) * c. +intros c p q Hq; unfold Zsum. +rewrite Zle_imp_le_bool; auto with zarith. +pattern ((1 + q) - p) at 2. + rewrite <- Zabs_eq; auto with zarith. + rewrite <- inj_Zabs_nat; auto with zarith. +cut (exists r , r = Zabs_nat ((1 + q) - p) ); + [intros [r H1]; rewrite <- H1 | exists (Zabs_nat ((1 + q) - p))]; auto. +generalize p; elim r; auto with zarith. +intros n H p0; replace (Z_of_nat (S n)) with (Z_of_nat n + 1); auto with zarith. +simpl; rewrite H; ring. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zsum_Zsum_f: + forall (i j k l : Z) (f : Z -> Z -> Z), + i <= j -> + k < l -> + Zsum i j (fun x => Zsum k (l + 1) (fun y => f x y)) = + Zsum i j (fun x => Zsum k l (fun y => f x y) + f x (l + 1)). +intros; apply Zsum_ext; intros; auto with zarith. +rewrite Zsum_S_right; auto with zarith. +Qed. + +Theorem Zsum_com: + forall (i j k l : Z) (f : Z -> Z -> Z), + Zsum i j (fun x => Zsum k l (fun y => f x y)) = + Zsum k l (fun y => Zsum i j (fun x => f x y)). +intros; unfold Zsum; case (Zle_bool i j); case (Zle_bool k l); apply iter_com; + auto with zarith. +Qed. + +Theorem Zsum_le: + forall (n m : Z) (f g : Z -> Z), + n <= m -> + (forall (x : Z), ( n <= x <= m ) -> (f x <= g x )) -> + (Zsum n m f <= Zsum n m g ). +intros n m f g Hl H. +unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith. +unfold Zsum; + cut + (forall x, + In x (progression Zsucc n (Zabs_nat ((1 + m) - n))) -> ( f x <= g x )). +elim (progression Zsucc n (Zabs_nat ((1 + m) - n))); simpl; auto with zarith. +intros x H1; apply H; split. +apply Zprogression_le_init with ( 1 := H1 ); auto. +cut (x < m + 1); auto with zarith. +replace (m + 1) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem iter_le: +forall (f g: Z -> Z) l, (forall a, In a l -> f a <= g a) -> + iter 0 f Zplus l <= iter 0 g Zplus l. +intros f g l; elim l; simpl; auto with zarith. +Qed. + +Theorem Zsum_lt: + forall n m f g, + (forall x, n <= x -> x <= m -> f x <= g x) -> + (exists x, n <= x /\ x <= m /\ f x < g x) -> + Zsum n m f < Zsum n m g. +intros n m f g H (d, (Hd1, (Hd2, Hd3))); unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith. +cut (In d (progression Zsucc n (Zabs_nat (1 + m - n)))). +cut (forall x, In x (progression Zsucc n (Zabs_nat (1 + m - n)))-> f x <= g x). +elim (progression Zsucc n (Zabs_nat (1 + m - n))); simpl; auto with zarith. +intros a l Rec H0 [H1 | H1]; subst; auto. +apply Zle_lt_trans with (f d + iter 0 g Zplus l); auto with zarith. +apply Zplus_le_compat_l. +apply iter_le; auto. +apply Zlt_le_trans with (f a + iter 0 g Zplus l); auto with zarith. +intros x H1; apply H. +apply Zprogression_le_init with ( 1 := H1 ); auto. +cut (x < m + 1); auto with zarith. +replace (m + 1) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end with ( 1 := H1 ); auto with arith. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +apply in_Zprogression. +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem Zsum_minus: + forall n m f g, Zsum n m f - Zsum n m g = Zsum n m (fun x => f x - g x). +intros n m f g; apply trans_equal with (Zsum n m f + (-1) * Zsum n m g); auto with zarith. +rewrite Zsum_times; rewrite Zsum_add; auto with zarith. +Qed. diff --git a/coqprime-8.5/Coqprime/Zp.v b/coqprime-8.5/Coqprime/Zp.v new file mode 100644 index 000000000..1e5295191 --- /dev/null +++ b/coqprime-8.5/Coqprime/Zp.v @@ -0,0 +1,411 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Zp.v + + Build the group of the inversible element on {1, 2, .., n-1} + for the multiplication modulo n + + Definition: ZpGroup + **********************************************************************) +Require Import ZArith Znumtheory Zpow_facts. +Require Import Tactic. +Require Import Wf_nat. +Require Import UList. +Require Import FGroup. +Require Import EGroup. +Require Import IGroup. +Require Import Cyclic. +Require Import Euler. +Require Import ZProgression. + +Open Scope Z_scope. + +Section Zp. + +Variable n: Z. + +Hypothesis n_pos: 1 < n. + + +(************************************** + mkZp m creates {m, m - 1, ..., 0} + **************************************) + +Fixpoint mkZp_aux (m: nat): list Z:= + Z_of_nat m :: match m with O => nil | (S m1) => mkZp_aux m1 end. + +(************************************** + Some properties of mkZp_aux + **************************************) + +Theorem mkZp_aux_length: forall m, length (mkZp_aux m) = (m + 1)%nat. +intros m; elim m; simpl; auto. +Qed. + +Theorem mkZp_aux_in: forall m p, 0 <= p <= Z_of_nat m -> In p (mkZp_aux m). +intros m; elim m. +simpl; auto with zarith. +intros n1 Rec p (H1, H2); case Zle_lt_or_eq with (1 := H2); clear H2; intro H2. +rewrite inj_S in H2. +simpl; right; apply Rec; split; auto with zarith. +rewrite H2; simpl; auto. +Qed. + +Theorem in_mkZp_aux: forall m p, In p (mkZp_aux m) -> 0 <= p <= Z_of_nat m. +intros m; elim m; clear m. +simpl; intros p H1; case H1; clear H1; intros H1; subst; auto with zarith. +intros m1; generalize (inj_S m1); simpl. +intros H Rec p [H1 | H1]. +rewrite <- H1; rewrite H; auto with zarith. +rewrite H; case (Rec p); auto with zarith. +Qed. + +Theorem mkZp_aux_ulist: forall m, ulist (mkZp_aux m). +intros m; elim m; simpl; auto. +intros m1 H; apply ulist_cons; auto. +change (~ In (Z_of_nat (S m1)) (mkZp_aux m1)). +rewrite inj_S; intros H1. +case in_mkZp_aux with (1 := H1); auto with zarith. +Qed. + +(************************************** + mkZp creates {n - 1, ..., 1, 0} + **************************************) + +Definition mkZp := mkZp_aux (Zabs_nat (n - 1)). + +(************************************** + Some properties of mkZp + **************************************) + +Theorem mkZp_length: length mkZp = Zabs_nat n. +unfold mkZp; rewrite mkZp_aux_length. +apply inj_eq_rev. +rewrite inj_plus. +simpl; repeat rewrite inj_Zabs_nat; auto with zarith. +repeat rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem mkZp_in: forall p, 0 <= p < n -> In p mkZp. +intros p (H1, H2); unfold mkZp; apply mkZp_aux_in. +rewrite inj_Zabs_nat; auto with zarith. +repeat rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem in_mkZp: forall p, In p mkZp -> 0 <= p < n. +intros p H; case (in_mkZp_aux (Zabs_nat (n - 1)) p); auto with zarith. +rewrite inj_Zabs_nat; auto with zarith. +repeat rewrite Zabs_eq; auto with zarith. +Qed. + +Theorem mkZp_ulist: ulist mkZp. +unfold mkZp; apply mkZp_aux_ulist; auto. +Qed. + +(************************************** + Multiplication of two pairs + **************************************) + +Definition pmult (p q: Z) := (p * q) mod n. + +(************************************** + Properties of multiplication + **************************************) + +Theorem pmult_assoc: forall p q r, (pmult p (pmult q r)) = (pmult (pmult p q) r). +assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith. +generalize Zmod_mod; intros H. +intros p q r; unfold pmult. +rewrite (Zmult_mod p); auto. +repeat rewrite Zmod_mod; auto. +rewrite (Zmult_mod q); auto. +rewrite <- Zmult_mod; auto. +rewrite Zmult_assoc. +rewrite (Zmult_mod (p * (q mod n))); auto. +rewrite (Zmult_mod ((p * q) mod n)); auto. +eq_tac; auto. +eq_tac; auto. +rewrite (Zmult_mod p); sauto. +rewrite Zmod_mod; auto. +rewrite <- Zmult_mod; sauto. +Qed. + +Theorem pmult_1_l: forall p, In p mkZp -> pmult 1 p = p. +intros p H; unfold pmult; rewrite Zmult_1_l. +apply Zmod_small. +case (in_mkZp p); auto with zarith. +Qed. + +Theorem pmult_1_r: forall p, In p mkZp -> pmult p 1 = p. +intros p H; unfold pmult; rewrite Zmult_1_r. +apply Zmod_small. +case (in_mkZp p); auto with zarith. +Qed. + +Theorem pmult_comm: forall p q, pmult p q = pmult q p. +intros p q; unfold pmult; rewrite Zmult_comm; auto. +Qed. + +Definition Lrel := isupport_aux _ pmult mkZp 1 Z_eq_dec (progression Zsucc 0 (Zabs_nat n)). + +Theorem rel_prime_is_inv: + forall a, is_inv Z pmult mkZp 1 Z_eq_dec a = if (rel_prime_dec a n) then true else false. +assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith. +intros a; case (rel_prime_dec a n); intros H. +assert (H1: Bezout a n 1); try apply rel_prime_bezout; auto. +inversion H1 as [c d Hcd]; clear H1. +assert (pmult (c mod n) a = 1). +unfold pmult; rewrite Zmult_mod; try rewrite Zmod_mod; auto. +rewrite <- Zmult_mod; auto. +replace (c * a) with (1 + (-d) * n). +rewrite Z_mod_plus; auto with zarith. +rewrite Zmod_small; auto with zarith. +rewrite <- Hcd; ring. +apply is_inv_true with (a := (c mod n)); auto. +apply mkZp_in; auto with zarith. +exact pmult_1_l. +exact pmult_1_r. +rewrite pmult_comm; auto. +apply mkZp_in; auto with zarith. +apply Z_mod_lt; auto with zarith. +apply is_inv_false. +intros c H1; left; intros H2; contradict H. +apply bezout_rel_prime. +apply Bezout_intro with c (- (Zdiv (c * a) n)). +pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) n); auto with zarith. +unfold pmult in H2; rewrite (Zmult_comm c); try rewrite H2. +ring. +Qed. + +(************************************** + We are now ready to build our group + **************************************) + +Definition ZPGroup : (FGroup pmult). +apply IGroup with (support := mkZp) (e:= 1). +exact Z_eq_dec. +apply mkZp_ulist. +apply mkZp_in; auto with zarith. +intros a b H1 H2; apply mkZp_in. +unfold pmult; apply Z_mod_lt; auto with zarith. +intros; apply pmult_assoc. +exact pmult_1_l. +exact pmult_1_r. +Defined. + +Theorem in_ZPGroup: forall p, rel_prime p n -> 0 <= p < n -> In p ZPGroup.(s). +intros p H (H1, H2); unfold ZPGroup; simpl. +apply isupport_is_in. +generalize (rel_prime_is_inv p); case (rel_prime_dec p); auto. +apply mkZp_in; auto with zarith. +Qed. + + +Theorem phi_is_length: phi n = Z_of_nat (length Lrel). +assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith. +rewrite phi_def_with_0; auto. +unfold Zsum, Lrel; rewrite Zle_imp_le_bool; auto with zarith. +replace (1 + (n - 1) - 0) with n; auto with zarith. +elim (progression Zsucc 0 (Zabs_nat n)); simpl; auto. +intros a l1 Rec. +rewrite Rec. +rewrite rel_prime_is_inv. +case (rel_prime_dec a n); auto with zarith. +simpl length; rewrite inj_S; auto with zarith. +Qed. + +Theorem phi_is_order: phi n = g_order ZPGroup. +unfold g_order; rewrite phi_is_length. +eq_tac; apply permutation_length. +apply ulist_incl2_permutation. +unfold Lrel; apply isupport_aux_ulist. +apply ulist_Zprogression; auto. +apply ZPGroup.(unique_s). +intros a H; unfold ZPGroup; simpl. +apply isupport_is_in. +unfold Lrel in H; apply isupport_aux_is_inv_true with (1 := H). +apply mkZp_in; auto. +assert (In a (progression Zsucc 0 (Zabs_nat n))). +apply (isupport_aux_incl _ pmult mkZp 1 Z_eq_dec); auto. +split. +apply Zprogression_le_init with (1 := H0). +replace n with (0 + Z_of_nat (Zabs_nat n)). +apply Zprogression_le_end with (1 := H0). +rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +intros a H; unfold Lrel; simpl. +apply isupport_aux_is_in. +simpl in H; apply isupport_is_inv_true with (1 := H). +apply in_Zprogression. +rewrite Zplus_0_l; rewrite inj_Zabs_nat; auto with zarith. +rewrite Zabs_eq; auto with zarith. +assert (In a mkZp). +apply (isupport_aux_incl _ pmult mkZp 1 Z_eq_dec); auto. +apply in_mkZp; auto. +Qed. + +Theorem Zp_cyclic: prime n -> cyclic Z_eq_dec ZPGroup. +intros H1. +unfold ZPGroup, pmult; +generalize (cyclic_field _ (fun x y => (x + y) mod n) (fun x y => (x * y) mod n) (fun x => (-x) mod n) 0); +unfold IA; intros tmp; apply tmp; clear tmp; auto. +intros; discriminate. +apply mkZp_in; auto with zarith. +intros; apply mkZp_in; auto with zarith. +apply Z_mod_lt; auto with zarith. +intros; rewrite Zplus_0_l; auto. +apply Zmod_small; auto. +apply in_mkZp; auto. +intros; rewrite Zplus_comm; auto. +intros a b c Ha Hb Hc. +pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith. +pattern c at 2; rewrite <- (Zmod_small c n); auto with zarith. +repeat rewrite <- Zplus_mod; auto with zarith. +eq_tac; auto with zarith. +apply in_mkZp; auto. +apply in_mkZp; auto. +intros; eq_tac; auto with zarith. +intros a b c Ha Hb Hc. +pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith. +repeat rewrite <- Zmult_mod; auto with zarith. +repeat rewrite <- Zplus_mod; auto with zarith. +eq_tac; auto with zarith. +apply in_mkZp; auto. +intros; apply mkZp_in; apply Z_mod_lt; auto with zarith. +intros a Ha. +pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith. +repeat rewrite <- Zplus_mod; auto with zarith. +rewrite <- (Zmod_small 0 n); auto with zarith. +eq_tac; auto with zarith. +apply in_mkZp; auto. +intros a b Ha Hb H; case (prime_mult n H1 a b). +apply Zmod_divide; auto with zarith. +intros H2; left. +case (Zle_lt_or_eq 0 a); auto. +case (in_mkZp a); auto. +intros H3; absurd (n <= a). +apply Zlt_not_le. +case (in_mkZp a); auto. +apply Zdivide_le; auto with zarith. +intros H2; right. +case (Zle_lt_or_eq 0 b); auto. +case (in_mkZp b); auto. +intros H3; absurd (n <= b). +apply Zlt_not_le. +case (in_mkZp b); auto. +apply Zdivide_le; auto with zarith. +Qed. + +End Zp. + +(* Definition of the order (0 for q < 1) *) + +Definition Zorder: Z -> Z -> Z. +intros p q; case (Z_le_dec q 1); intros H. +exact 0. +refine (e_order Z_eq_dec (p mod q) (ZPGroup q _)); auto with zarith. +Defined. + +Theorem Zorder_pos: forall p n, 0 <= Zorder p n. +intros p n; unfold Zorder. +case (Z_le_dec n 1); auto with zarith. +intros n1. +apply Zlt_le_weak; apply e_order_pos. +Qed. + +Theorem in_mod_ZPGroup + : forall (n : Z) (n_pos : 1 < n) (p : Z), + rel_prime p n -> In (p mod n) (s (ZPGroup n n_pos)). +intros n H p H1. +apply in_ZPGroup; auto. +apply rel_prime_mod; auto with zarith. +apply Z_mod_lt; auto with zarith. +Qed. + + +Theorem Zpower_mod_is_gpow: + forall p q n (Hn: 1 < n), rel_prime p n -> 0 <= q -> p ^ q mod n = gpow (p mod n) (ZPGroup n Hn) q. +intros p q n H Hp H1; generalize H1; pattern q; apply natlike_ind; simpl; auto. +intros _; apply Zmod_small; auto with zarith. +intros n1 Hn1 Rec _; simpl. +generalize (in_mod_ZPGroup _ H _ Hp); intros Hu. +unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. +rewrite gpow_add; auto with zarith. +rewrite gpow_1; auto; rewrite <- Rec; auto. +rewrite Zmult_mod; auto. +Qed. + + +Theorem Zorder_div_power: forall p q n, 1 < n -> rel_prime p n -> p ^ q mod n = 1 -> (Zorder p n | q). +intros p q n H H1 H2. +assert (Hq: 0 <= q). +generalize H2; case q; simpl; auto with zarith. +intros p1 H3; contradict H3; rewrite Zmod_small; auto with zarith. +unfold Zorder; case (Z_le_dec n 1). +intros H3; contradict H; auto with zarith. +intros H3; apply e_order_divide_gpow; auto. +apply in_mod_ZPGroup; auto. +rewrite <- Zpower_mod_is_gpow; auto with zarith. +Qed. + +Theorem Zorder_div: forall p n, prime n -> ~(n | p) -> (Zorder p n | n - 1). +intros p n H; unfold Zorder. +case (Z_le_dec n 1); intros H1 H2. +contradict H1; generalize (prime_ge_2 n H); auto with zarith. +rewrite <- prime_phi_n_minus_1; auto. +match goal with |- context[ZPGroup _ ?H2] => rewrite phi_is_order with (n_pos := H2) end. +apply e_order_divide_g_order; auto. +apply in_mod_ZPGroup; auto. +apply rel_prime_sym; apply prime_rel_prime; auto. +Qed. + + +Theorem Zorder_power_is_1: forall p n, 1 < n -> rel_prime p n -> p ^ (Zorder p n) mod n = 1. +intros p n H H1; unfold Zorder. +case (Z_le_dec n 1); intros H2. +contradict H; auto with zarith. +let x := match goal with |- context[ZPGroup _ ?X] => X end in rewrite Zpower_mod_is_gpow with (Hn := x); auto with zarith. +rewrite gpow_e_order_is_e. +reflexivity. +apply in_mod_ZPGroup; auto. +apply Zlt_le_weak; apply e_order_pos. +Qed. + +Theorem Zorder_power_pos: forall p n, 1 < n -> rel_prime p n -> 0 < Zorder p n. +intros p n H H1; unfold Zorder. +case (Z_le_dec n 1); intros H2. +contradict H; auto with zarith. +apply e_order_pos. +Qed. + +Theorem phi_power_is_1: forall p n, 1 < n -> rel_prime p n -> p ^ (phi n) mod n = 1. +intros p n H H1. +assert (V1:= Zorder_power_pos p n H H1). +assert (H2: (Zorder p n | phi n)). +unfold Zorder. +case (Z_le_dec n 1); intros H2. +contradict H; auto with zarith. +match goal with |- context[ZPGroup n ?H] => +rewrite phi_is_order with (n_pos := H) +end. +apply e_order_divide_g_order. +apply in_mod_ZPGroup; auto. +case H2; clear H2; intros q H2; rewrite H2. +rewrite Zmult_comm. +assert (V2 := (phi_pos _ H)). +assert (V3: 0 <= q). +rewrite H2 in V2. +apply Zlt_le_weak; apply Zmult_lt_0_reg_r with (2 := V2); auto with zarith. +rewrite Zpower_mult; auto with zarith. +rewrite Zpower_mod; auto with zarith. +rewrite Zorder_power_is_1; auto. +rewrite Zpower_1_l; auto with zarith. +apply Zmod_small; auto with zarith. +Qed. diff --git a/coqprime-8.5/Makefile b/coqprime-8.5/Makefile new file mode 100644 index 000000000..c8e44a658 --- /dev/null +++ b/coqprime-8.5/Makefile @@ -0,0 +1,319 @@ +############################################################################# +## v # The Coq Proof Assistant ## +## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## +## \VV/ # ## +## // # Makefile automagically generated by coq_makefile V8.5pl1 ## +############################################################################# + +# WARNING +# +# This Makefile has been automagically generated +# Edit at your own risks ! +# +# END OF WARNING + +# +# This Makefile was generated by the command line : +# coq_makefile -f _CoqProject -o Makefile +# + +.DEFAULT_GOAL := all + +# This Makefile may take arguments passed as environment variables: +# COQBIN to specify the directory where Coq binaries resides; +# TIMECMD set a command to log .v compilation time; +# TIMED if non empty, use the default time command as TIMECMD; +# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc; +# DSTROOT to specify a prefix to install path. + +# Here is a hack to make $(eval $(shell works: +define donewline + + +endef +includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\r' | tr '\n' '@'; }))) +$(call includecmdwithout@,$(COQBIN)coqtop -config) + +TIMED= +TIMECMD= +STDTIME?=/usr/bin/time -f "$* (user: %U mem: %M ko)" +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1)))) + +########################## +# # +# Libraries definitions. # +# # +########################## + +COQLIBS?=\ + -R "Coqprime" Coqprime +COQDOCLIBS?=\ + -R "Coqprime" Coqprime + +########################## +# # +# Variables definitions. # +# # +########################## + + +OPT?= +COQDEP?="$(COQBIN)coqdep" -c +COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML) +COQCHKFLAGS?=-silent -o +COQDOCFLAGS?=-interpolate -utf8 +COQC?=$(TIMER) "$(COQBIN)coqc" +GALLINA?="$(COQBIN)gallina" +COQDOC?="$(COQBIN)coqdoc" +COQCHK?="$(COQBIN)coqchk" +COQMKTOP?="$(COQBIN)coqmktop" + +################## +# # +# Install Paths. # +# # +################## + +ifdef USERINSTALL +XDG_DATA_HOME?="$(HOME)/.local/share" +COQLIBINSTALL=$(XDG_DATA_HOME)/coq +COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq +else +COQLIBINSTALL="${COQLIB}user-contrib" +COQDOCINSTALL="${DOCDIR}user-contrib" +COQTOPINSTALL="${COQLIB}toploop" +endif + +###################### +# # +# Files dispatching. # +# # +###################### + +VFILES:=Coqprime/Cyclic.v\ + Coqprime/EGroup.v\ + Coqprime/Euler.v\ + Coqprime/FGroup.v\ + Coqprime/IGroup.v\ + Coqprime/Iterator.v\ + Coqprime/Lagrange.v\ + Coqprime/ListAux.v\ + Coqprime/LucasLehmer.v\ + Coqprime/NatAux.v\ + Coqprime/PGroup.v\ + Coqprime/Permutation.v\ + Coqprime/Pmod.v\ + Coqprime/Pocklington.v\ + Coqprime/PocklingtonCertificat.v\ + Coqprime/Root.v\ + Coqprime/Tactic.v\ + Coqprime/UList.v\ + Coqprime/ZCAux.v\ + Coqprime/ZCmisc.v\ + Coqprime/ZProgression.v\ + Coqprime/ZSum.v\ + Coqprime/Zp.v + +ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),) +-include $(addsuffix .d,$(VFILES)) +else +ifeq ($(MAKECMDGOALS),) +-include $(addsuffix .d,$(VFILES)) +endif +endif + +.SECONDARY: $(addsuffix .d,$(VFILES)) + +VO=vo +VOFILES:=$(VFILES:.v=.$(VO)) +VOFILES1=$(patsubst Coqprime/%,%,$(filter Coqprime/%,$(VOFILES))) +GLOBFILES:=$(VFILES:.v=.glob) +GFILES:=$(VFILES:.v=.g) +HTMLFILES:=$(VFILES:.v=.html) +GHTMLFILES:=$(VFILES:.v=.g.html) +OBJFILES=$(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES=$(OBJFILES:.o=.cmi) $(OBJFILES:.o=.cmo) $(OBJFILES:.o=.cmx) $(OBJFILES:.o=.cmxs) +NATIVEFILES=$(foreach f, $(ALLNATIVEFILES), $(wildcard $f)) +NATIVEFILES1=$(patsubst Coqprime/%,%,$(filter Coqprime/%,$(NATIVEFILES))) +ifeq '$(HASNATDYNLINK)' 'true' +HASNATDYNLINK_OR_EMPTY := yes +else +HASNATDYNLINK_OR_EMPTY := +endif + +####################################### +# # +# Definition of the toplevel targets. # +# # +####################################### + +all: $(VOFILES) + +quick: $(VOFILES:.vo=.vio) + +vio2vo: + $(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +checkproofs: + $(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +gallina: $(GFILES) + +html: $(GLOBFILES) $(VFILES) + - mkdir -p html + $(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES) + +gallinahtml: $(GLOBFILES) $(VFILES) + - mkdir -p html + $(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES) + +all.ps: $(VFILES) + $(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` + +all-gal.ps: $(VFILES) + $(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` + +all.pdf: $(VFILES) + $(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` + +all-gal.pdf: $(VFILES) + $(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^` + +validate: $(VOFILES) + $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=)) + +beautify: $(VFILES:=.beautified) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' + +.PHONY: all archclean beautify byte clean cleanall gallina gallinahtml html install install-doc install-natdynlink install-toploop opt printenv quick uninstall userinstall validate vio2vo + +#################### +# # +# Special targets. # +# # +#################### + +byte: + $(MAKE) all "OPT:=-byte" + +opt: + $(MAKE) all "OPT:=-opt" + +userinstall: + +$(MAKE) USERINSTALL=true install + +install: + cd "Coqprime" && for i in $(NATIVEFILES1) $(GLOBFILES1) $(VFILES1) $(VOFILES1); do \ + install -d "`dirname "$(DSTROOT)"$(COQLIBINSTALL)/Coqprime/$$i`"; \ + install -m 0644 $$i "$(DSTROOT)"$(COQLIBINSTALL)/Coqprime/$$i; \ + done + +install-doc: + install -d "$(DSTROOT)"$(COQDOCINSTALL)/Coqprime/html + for i in html/*; do \ + install -m 0644 $$i "$(DSTROOT)"$(COQDOCINSTALL)/Coqprime/$$i;\ + done + +uninstall_me.sh: Makefile + echo '#!/bin/sh' > $@ + printf 'cd "$${DSTROOT}"$(COQLIBINSTALL)/Coqprime && rm -f $(NATIVEFILES1) $(GLOBFILES1) $(VFILES1) $(VOFILES1) && find . -type d -and -empty -delete\ncd "$${DSTROOT}"$(COQLIBINSTALL) && find "Coqprime" -maxdepth 0 -and -empty -exec rmdir -p \{\} \;\n' >> "$@" + printf 'cd "$${DSTROOT}"$(COQDOCINSTALL)/Coqprime \\\n' >> "$@" + printf '&& rm -f $(shell find "html" -maxdepth 1 -and -type f -print)\n' >> "$@" + printf 'cd "$${DSTROOT}"$(COQDOCINSTALL) && find Coqprime/html -maxdepth 0 -and -empty -exec rmdir -p \{\} \;\n' >> "$@" + chmod +x $@ + +uninstall: uninstall_me.sh + sh $< + +.merlin: + @echo 'FLG -rectypes' > .merlin + @echo "B $(COQLIB) kernel" >> .merlin + @echo "B $(COQLIB) lib" >> .merlin + @echo "B $(COQLIB) library" >> .merlin + @echo "B $(COQLIB) parsing" >> .merlin + @echo "B $(COQLIB) pretyping" >> .merlin + @echo "B $(COQLIB) interp" >> .merlin + @echo "B $(COQLIB) printing" >> .merlin + @echo "B $(COQLIB) intf" >> .merlin + @echo "B $(COQLIB) proofs" >> .merlin + @echo "B $(COQLIB) tactics" >> .merlin + @echo "B $(COQLIB) tools" >> .merlin + @echo "B $(COQLIB) toplevel" >> .merlin + @echo "B $(COQLIB) stm" >> .merlin + @echo "B $(COQLIB) grammar" >> .merlin + @echo "B $(COQLIB) config" >> .merlin + +clean:: + rm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES) + find . -name .coq-native -type d -empty -delete + rm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old) + rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex + - rm -rf html mlihtml uninstall_me.sh + +cleanall:: clean + rm -f $(patsubst %.v,.%.aux,$(VFILES)) + +archclean:: + rm -f *.cmx *.o + +printenv: + @"$(COQBIN)coqtop" -config + @echo 'CAMLC = $(CAMLC)' + @echo 'CAMLOPTC = $(CAMLOPTC)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' + +Makefile: _CoqProject + mv -f $@ $@.bak + "$(COQBIN)coq_makefile" -f $< -o $@ + + +################### +# # +# Implicit rules. # +# # +################### + +$(VOFILES): %.vo: %.v + $(COQC) $(COQDEBUG) $(COQFLAGS) $* + +$(GLOBFILES): %.glob: %.v + $(COQC) $(COQDEBUG) $(COQFLAGS) $* + +$(VFILES:.v=.vio): %.vio: %.v + $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $* + +$(GFILES): %.g: %.v + $(GALLINA) $< + +$(VFILES:.v=.tex): %.tex: %.v + $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(VFILES:.v=.g.tex): %.g.tex: %.v + $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +$(addsuffix .d,$(VFILES)): %.v.d: %.v + $(COQDEP) $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) + +$(addsuffix .beautified,$(VFILES)): %.v.beautified: + $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* + +# WARNING +# +# This Makefile has been automagically generated +# Edit at your own risks ! +# +# END OF WARNING + diff --git a/coqprime-8.5/README.md b/coqprime-8.5/README.md new file mode 100644 index 000000000..9c317fb00 --- /dev/null +++ b/coqprime-8.5/README.md @@ -0,0 +1,9 @@ +# Coqprime (LGPL subset) + +This is a mirror of the LGPL-licensed and autogenerated files from [Coqprime](http://coqprime.gforge.inria.fr/) for Coq 8.5. It was generated from [coqprime_8.5b.zip](https://gforge.inria.fr/frs/download.php/file/35520/coqprime_8.5b.zip). Due to the removal of files that are missing license headers in the upstream source, `make` no longer completes successfully. However, a large part of the codebase does build and contains theorems useful to us. Fixing the build system would be nice, but is not a priority for us. + +## Usage + + make PrimalityTest/Zp.vo PrimalityTest/PocklingtonCertificat.vo + cd .. + coqide -R coqprime/Tactic Coqprime -R coqprime/N Coqprime -R coqprime/Z Coqprime -R coqprime/List Coqprime -R coqprime/PrimalityTest Coqprime YOUR_FILE.v # these are the dependencies for PrimalityTest/Zp, other modules can be added in a similar fashion diff --git a/coqprime-8.5/_CoqProject b/coqprime-8.5/_CoqProject new file mode 100644 index 000000000..95b224864 --- /dev/null +++ b/coqprime-8.5/_CoqProject @@ -0,0 +1,24 @@ +-R Coqprime Coqprime +Coqprime/Cyclic.v +Coqprime/EGroup.v +Coqprime/Euler.v +Coqprime/FGroup.v +Coqprime/IGroup.v +Coqprime/Iterator.v +Coqprime/Lagrange.v +Coqprime/ListAux.v +Coqprime/LucasLehmer.v +Coqprime/NatAux.v +Coqprime/PGroup.v +Coqprime/Permutation.v +Coqprime/Pmod.v +Coqprime/Pocklington.v +Coqprime/PocklingtonCertificat.v +Coqprime/Root.v +Coqprime/Tactic.v +Coqprime/UList.v +Coqprime/ZCAux.v +Coqprime/ZCmisc.v +Coqprime/ZProgression.v +Coqprime/ZSum.v +Coqprime/Zp.v diff --git a/src/Algebra.v b/src/Algebra.v new file mode 100644 index 000000000..6dc188e2c --- /dev/null +++ b/src/Algebra.v @@ -0,0 +1,598 @@ +Require Import Coq.Classes.Morphisms. Require Coq.Setoids.Setoid. +Require Import Crypto.Util.Tactics Crypto.Tactics.Nsatz. +Local Close Scope nat_scope. Local Close Scope type_scope. Local Close Scope core_scope. + +Section Algebra. + Context {T:Type} {eq:T->T->Prop}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + + Class is_eq_dec := { eq_dec : forall x y : T, {x=y} + {x<>y} }. + + Section SingleOperation. + Context {op:T->T->T}. + + Class is_associative := { associative : forall x y z, op x (op y z) = op (op x y) z }. + + Context {id:T}. + + Class is_left_identity := { left_identity : forall x, op id x = x }. + Class is_right_identity := { right_identity : forall x, op x id = x }. + + Class monoid := + { + monoid_is_associative : is_associative; + monoid_is_left_identity : is_left_identity; + monoid_is_right_identity : is_right_identity; + + monoid_op_Proper: Proper (respectful eq (respectful eq eq)) op; + monoid_Equivalence : Equivalence eq; + monoid_is_eq_dec : is_eq_dec + }. + Global Existing Instance monoid_is_associative. + Global Existing Instance monoid_is_left_identity. + Global Existing Instance monoid_is_right_identity. + Global Existing Instance monoid_Equivalence. + Global Existing Instance monoid_is_eq_dec. + Global Existing Instance monoid_op_Proper. + + Context {inv:T->T}. + Class is_left_inverse := { left_inverse : forall x, op (inv x) x = id }. + Class is_right_inverse := { right_inverse : forall x, op x (inv x) = id }. + + Class group := + { + group_monoid : monoid; + group_is_left_inverse : is_left_inverse; + group_is_right_inverse : is_right_inverse; + + group_inv_Proper: Proper (respectful eq eq) inv + }. + Global Existing Instance group_monoid. + Global Existing Instance group_is_left_inverse. + Global Existing Instance group_is_right_inverse. + Global Existing Instance group_inv_Proper. + + Class is_commutative := { commutative : forall x y, op x y = op y x }. + + Record abelian_group := + { + abelian_group_group : group; + abelian_group_is_commutative : is_commutative + }. + Existing Class abelian_group. + Global Existing Instance abelian_group_group. + Global Existing Instance abelian_group_is_commutative. + End SingleOperation. + + Section AddMul. + Context {zero one:T}. Local Notation "0" := zero. Local Notation "1" := one. + Context {opp:T->T}. Local Notation "- x" := (opp x). + Context {add:T->T->T} {sub:T->T->T} {mul:T->T->T}. + Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul. + + Class is_left_distributive := { left_distributive : forall a b c, a * (b + c) = a * b + a * c }. + Class is_right_distributive := { right_distributive : forall a b c, (b + c) * a = b * a + c * a }. + + + Class ring := + { + ring_abelian_group_add : abelian_group (op:=add) (id:=zero) (inv:=opp); + ring_monoid_mul : monoid (op:=mul) (id:=one); + ring_is_left_distributive : is_left_distributive; + ring_is_right_distributive : is_right_distributive; + + ring_sub_definition : forall x y, x - y = x + opp y; + + ring_mul_Proper : Proper (respectful eq (respectful eq eq)) mul; + ring_sub_Proper : Proper(respectful eq (respectful eq eq)) sub + }. + Global Existing Instance ring_abelian_group_add. + Global Existing Instance ring_monoid_mul. + Global Existing Instance ring_is_left_distributive. + Global Existing Instance ring_is_right_distributive. + Global Existing Instance ring_mul_Proper. + Global Existing Instance ring_sub_Proper. + + Class commutative_ring := + { + commutative_ring_ring : ring; + commutative_ring_is_commutative : is_commutative (op:=mul) + }. + Global Existing Instance commutative_ring_ring. + Global Existing Instance commutative_ring_is_commutative. + + Class is_mul_nonzero_nonzero := { mul_nonzero_nonzero : forall x y, x<>0 -> y<>0 -> x*y<>0 }. + + Class is_zero_neq_one := { zero_neq_one : zero <> one }. + + Class integral_domain := + { + integral_domain_commutative_ring : commutative_ring; + integral_domain_is_mul_nonzero_nonzero : is_mul_nonzero_nonzero; + integral_domain_is_zero_neq_one : is_zero_neq_one + }. + Global Existing Instance integral_domain_commutative_ring. + Global Existing Instance integral_domain_is_mul_nonzero_nonzero. + Global Existing Instance integral_domain_is_zero_neq_one. + + Context {inv:T->T} {div:T->T->T}. + Class is_left_multiplicative_inverse := { left_multiplicative_inverse : forall x, x<>0 -> (inv x) * x = 1 }. + + Class field := + { + field_commutative_ring : commutative_ring; + field_is_left_multiplicative_inverse : is_left_multiplicative_inverse; + field_domain_is_zero_neq_one : is_zero_neq_one; + + field_div_definition : forall x y , div x y = x * inv y; + + field_inv_Proper : Proper (respectful eq eq) inv; + field_div_Proper : Proper (respectful eq (respectful eq eq)) div + }. + Global Existing Instance field_commutative_ring. + Global Existing Instance field_is_left_multiplicative_inverse. + Global Existing Instance field_domain_is_zero_neq_one. + Global Existing Instance field_inv_Proper. + Global Existing Instance field_div_Proper. + End AddMul. +End Algebra. + + +Module Monoid. + Section Monoid. + Context {T eq op id} {monoid:@monoid T eq op id}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Infix "*" := op. + Local Infix "=" := eq : eq_scope. + Local Open Scope eq_scope. + + Lemma cancel_right z iz (Hinv:op z iz = id) : + forall x y, x * z = y * z <-> x = y. + Proof. + split; intros. + { assert (op (op x z) iz = op (op y z) iz) as Hcut by (f_equiv; assumption). + rewrite <-associative in Hcut. + rewrite <-!associative, !Hinv, !right_identity in Hcut; exact Hcut. } + { f_equiv; assumption. } + Qed. + + Lemma cancel_left z iz (Hinv:op iz z = id) : + forall x y, z * x = z * y <-> x = y. + Proof. + split; intros. + { assert (op iz (op z x) = op iz (op z y)) as Hcut by (f_equiv; assumption). + rewrite !associative, !Hinv, !left_identity in Hcut; exact Hcut. } + { f_equiv; assumption. } + Qed. + + Lemma inv_inv x ix iix : ix*x = id -> iix*ix = id -> iix = x. + Proof. + intros Hi Hii. + assert (H:op iix id = op iix (op ix x)) by (rewrite Hi; reflexivity). + rewrite associative, Hii, left_identity, right_identity in H; exact H. + Qed. + + Lemma inv_op x y ix iy : ix*x = id -> iy*y = id -> (iy*ix)*(x*y) =id. + Proof. + intros Hx Hy. + cut (iy * (ix*x) * y = id); try intro H. + { rewrite <-!associative; rewrite <-!associative in H; exact H. } + rewrite Hx, right_identity, Hy. reflexivity. + Qed. + + End Monoid. +End Monoid. + +Section ZeroNeqOne. + Context {T eq zero one} `{@is_zero_neq_one T eq zero one} `{Equivalence T eq}. + + Lemma one_neq_zero : not (eq one zero). + Proof. + intro HH; symmetry in HH. auto using zero_neq_one. + Qed. +End ZeroNeqOne. + +Module Group. + Section BasicProperties. + Context {T eq op id inv} `{@group T eq op id inv}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Infix "*" := op. + Local Infix "=" := eq : eq_scope. + Local Open Scope eq_scope. + + Lemma cancel_left : forall z x y, z*x = z*y <-> x = y. + Proof. eauto using Monoid.cancel_left, left_inverse. Qed. + Lemma cancel_right : forall z x y, x*z = y*z <-> x = y. + Proof. eauto using Monoid.cancel_right, right_inverse. Qed. + Lemma inv_inv x : inv(inv(x)) = x. + Proof. eauto using Monoid.inv_inv, left_inverse. Qed. + Lemma inv_op x y : (inv y*inv x)*(x*y) =id. + Proof. eauto using Monoid.inv_op, left_inverse. Qed. + + Lemma inv_unique x ix : ix * x = id -> ix = inv x. + Proof. + intro Hix. + cut (ix*x*inv x = inv x). + - rewrite <-associative, right_inverse, right_identity; trivial. + - rewrite Hix, left_identity; reflexivity. + Qed. + + Lemma inv_id : inv id = id. + Proof. symmetry. eapply inv_unique, left_identity. Qed. + + Lemma inv_nonzero_nonzero : forall x, x <> id -> inv x <> id. + Proof. + intros ? Hx Ho. + assert (Hxo: x * inv x = id) by (rewrite right_inverse; reflexivity). + rewrite Ho, right_identity in Hxo. intuition. + Qed. + + Section ZeroNeqOne. + Context {one} `{is_zero_neq_one T eq id one}. + Lemma opp_one_neq_zero : inv one <> id. + Proof. apply inv_nonzero_nonzero, one_neq_zero. Qed. + Lemma zero_neq_opp_one : id <> inv one. + Proof. intro Hx. symmetry in Hx. eauto using opp_one_neq_zero. Qed. + End ZeroNeqOne. + End BasicProperties. + + Section Homomorphism. + Context {G EQ OP ID INV} {groupG:@group G EQ OP ID INV}. + Context {H eq op id inv} {groupH:@group H eq op id inv}. + Context {phi:G->H}. + Local Infix "=" := eq. Local Infix "=" := eq : type_scope. + + Class is_homomorphism := + { + homomorphism : forall a b, phi (OP a b) = op (phi a) (phi b); + + is_homomorphism_phi_proper : Proper (respectful EQ eq) phi + }. + Global Existing Instance is_homomorphism_phi_proper. + Context `{is_homomorphism}. + + Lemma homomorphism_id : phi ID = id. + Proof. + assert (Hii: op (phi ID) (phi ID) = op (phi ID) id) by + (rewrite <- homomorphism, left_identity, right_identity; reflexivity). + rewrite cancel_left in Hii; exact Hii. + Qed. + + Lemma homomorphism_inv : forall x, phi (INV x) = inv (phi x). + Proof. + Admitted. + End Homomorphism. +End Group. + +Require Coq.nsatz.Nsatz. + +Ltac dropAlgebraSyntax := + cbv beta delta [ + Algebra_syntax.zero + Algebra_syntax.one + Algebra_syntax.addition + Algebra_syntax.multiplication + Algebra_syntax.subtraction + Algebra_syntax.opposite + Algebra_syntax.equality + Algebra_syntax.bracket + Algebra_syntax.power + ] in *. + +Ltac dropRingSyntax := + dropAlgebraSyntax; + cbv beta delta [ + Ncring.zero_notation + Ncring.one_notation + Ncring.add_notation + Ncring.mul_notation + Ncring.sub_notation + Ncring.opp_notation + Ncring.eq_notation + ] in *. + +Module Ring. + Section Ring. + Context {T eq zero one opp add sub mul} `{@ring T eq zero one opp add sub mul}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := zero. Local Notation "1" := one. + Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul. + + Lemma mul_0_r : forall x, 0 * x = 0. + Proof. + intros. + assert (0*x = 0*x) as Hx by reflexivity. + rewrite <-(right_identity 0), right_distributive in Hx at 1. + assert (0*x + 0*x - 0*x = 0*x - 0*x) as Hxx by (f_equiv; exact Hx). + rewrite !ring_sub_definition, <-associative, right_inverse, right_identity in Hxx; exact Hxx. + Qed. + + Lemma mul_0_l : forall x, x * 0 = 0. + Proof. + intros. + assert (x*0 = x*0) as Hx by reflexivity. + rewrite <-(left_identity 0), left_distributive in Hx at 1. + assert (opp (x*0) + (x*0 + x*0) = opp (x*0) + x*0) as Hxx by (f_equiv; exact Hx). + rewrite associative, left_inverse, left_identity in Hxx; exact Hxx. + Qed. + + Lemma sub_0_l x : 0 - x = opp x. + Proof. rewrite ring_sub_definition. rewrite left_identity. reflexivity. Qed. + + Lemma mul_opp_r x y : x * opp y = opp (x * y). + Proof. + assert (Ho:x*(opp y) + x*y = 0) + by (rewrite <-left_distributive, left_inverse, mul_0_l; reflexivity). + rewrite <-(left_identity (opp (x*y))), <-Ho; clear Ho. + rewrite <-!associative, right_inverse, right_identity; reflexivity. + Qed. + + Lemma mul_opp_l x y : opp x * y = opp (x * y). + Proof. + assert (Ho:opp x*y + x*y = 0) + by (rewrite <-right_distributive, left_inverse, mul_0_r; reflexivity). + rewrite <-(left_identity (opp (x*y))), <-Ho; clear Ho. + rewrite <-!associative, right_inverse, right_identity; reflexivity. + Qed. + + Definition opp_nonzero_nonzero : forall x, x <> 0 -> opp x <> 0 := Group.inv_nonzero_nonzero. + + Global Instance is_left_distributive_sub : is_left_distributive (eq:=eq)(add:=sub)(mul:=mul). + Proof. + split; intros. rewrite !ring_sub_definition, left_distributive. + eapply Group.cancel_left, mul_opp_r. + Qed. + + Global Instance is_right_distributive_sub : is_right_distributive (eq:=eq)(add:=sub)(mul:=mul). + Proof. + split; intros. rewrite !ring_sub_definition, right_distributive. + eapply Group.cancel_left, mul_opp_l. + Qed. + + Global Instance Ncring_Ring_ops : @Ncring.Ring_ops T zero one add mul sub opp eq. + Global Instance Ncring_Ring : @Ncring.Ring T zero one add mul sub opp eq Ncring_Ring_ops. + Proof. + split; dropRingSyntax; eauto using left_identity, right_identity, commutative, associative, right_inverse, left_distributive, right_distributive, ring_sub_definition with core typeclass_instances. + - (* TODO: why does [eauto using @left_identity with typeclass_instances] not work? *) + eapply @left_identity; eauto with typeclass_instances. + - eapply @right_identity; eauto with typeclass_instances. + - eapply associative. + - intros; eapply right_distributive. + - intros; eapply left_distributive. + Qed. + End Ring. + + Section Homomorphism. + Context {R EQ ZERO ONE OPP ADD SUB MUL} `{@ring R EQ ZERO ONE OPP ADD SUB MUL}. + Context {S eq zero one opp add sub mul} `{@ring S eq zero one opp add sub mul}. + Context {phi:R->S}. + Local Infix "=" := eq. Local Infix "=" := eq : type_scope. + + Class is_homomorphism := + { + homomorphism_is_homomorphism : Group.is_homomorphism (phi:=phi) (OP:=ADD) (op:=add) (EQ:=EQ) (eq:=eq); + homomorphism_mul : forall x y, phi (MUL x y) = mul (phi x) (phi y); + homomorphism_one : phi ONE = one + }. + Global Existing Instance homomorphism_is_homomorphism. + + Context `{is_homomorphism}. + + Lemma homomorphism_add : forall x y, phi (ADD x y) = add (phi x) (phi y). + Proof. apply Group.homomorphism. Qed. + + Definition homomorphism_opp : forall x, phi (OPP x) = opp (phi x) := + (Group.homomorphism_inv (INV:=OPP) (inv:=opp)). + + Lemma homomorphism_sub : forall x y, phi (SUB x y) = sub (phi x) (phi y). + Proof. + intros. + rewrite !ring_sub_definition, Group.homomorphism, homomorphism_opp. reflexivity. + Qed. + + End Homomorphism. + + Section TacticSupportCommutative. + Context {T eq zero one opp add sub mul} `{@commutative_ring T eq zero one opp add sub mul}. + + Global Instance Cring_Cring_commutative_ring : + @Cring.Cring T zero one add mul sub opp eq Ring.Ncring_Ring_ops Ring.Ncring_Ring. + Proof. unfold Cring.Cring; intros; dropRingSyntax. eapply commutative. Qed. + + Lemma ring_theory_for_stdlib_tactic : Ring_theory.ring_theory zero one add mul sub opp eq. + Proof. + constructor; intros. (* TODO(automation): make [auto] do this? *) + - apply left_identity. + - apply commutative. + - apply associative. + - apply left_identity. + - apply commutative. + - apply associative. + - apply right_distributive. + - apply ring_sub_definition. + - apply right_inverse. + Qed. + End TacticSupportCommutative. +End Ring. + +Module IntegralDomain. + Section IntegralDomain. + Context {T eq zero one opp add sub mul} `{@integral_domain T eq zero one opp add sub mul}. + + Lemma mul_nonzero_nonzero_cases (x y : T) + : eq (mul x y) zero -> eq x zero \/ eq y zero. + Proof. + pose proof mul_nonzero_nonzero x y. + destruct (eq_dec x zero); destruct (eq_dec y zero); intuition. + Qed. + + Global Instance Integral_domain : + @Integral_domain.Integral_domain T zero one add mul sub opp eq Ring.Ncring_Ring_ops + Ring.Ncring_Ring Ring.Cring_Cring_commutative_ring. + Proof. + split; dropRingSyntax. + - auto using mul_nonzero_nonzero_cases. + - intro bad; symmetry in bad; auto using zero_neq_one. + Qed. + End IntegralDomain. +End IntegralDomain. + +Module Field. + Section Field. + Context {T eq zero one opp add mul sub inv div} `{@field T eq zero one opp add sub mul inv div}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := zero. Local Notation "1" := one. + Local Infix "+" := add. Local Infix "*" := mul. + + Global Instance is_mul_nonzero_nonzero : @is_mul_nonzero_nonzero T eq 0 mul. + Proof. + constructor. intros x y Hx Hy Hxy. + assert (0 = (inv y * (inv x * x)) * y) as H00. (rewrite <-!associative, Hxy, !Ring.mul_0_l; reflexivity). + rewrite left_multiplicative_inverse in H00 by assumption. + rewrite right_identity in H00. + rewrite left_multiplicative_inverse in H00 by assumption. + auto using zero_neq_one. + Qed. + + Global Instance integral_domain : @integral_domain T eq zero one opp add sub mul. + Proof. + split; auto using field_commutative_ring, field_domain_is_zero_neq_one, is_mul_nonzero_nonzero. + Qed. + + Require Coq.setoid_ring.Field_theory. + Lemma field_theory_for_stdlib_tactic : Field_theory.field_theory 0 1 add mul sub opp div inv eq. + Proof. + constructor. + { apply Ring.ring_theory_for_stdlib_tactic. } + { intro H01. symmetry in H01. auto using zero_neq_one. } + { apply field_div_definition. } + { apply left_multiplicative_inverse. } + Qed. + + End Field. + + Section Homomorphism. + Context {F EQ ZERO ONE OPP ADD MUL SUB INV DIV} `{@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}. + Context {K eq zero one opp add mul sub inv div} `{@field K eq zero one opp add sub mul inv div}. + Context {phi:F->K}. + Local Infix "=" := eq. Local Infix "=" := eq : type_scope. + Context `{@Ring.is_homomorphism F EQ ONE ADD MUL K eq one add mul phi}. + + Lemma homomorphism_multiplicative_inverse : forall x, phi (INV x) = inv (phi x). Admitted. + + Lemma homomorphism_div : forall x y, phi (DIV x y) = div (phi x) (phi y). + Proof. + intros. rewrite !field_div_definition. + rewrite Ring.homomorphism_mul, homomorphism_multiplicative_inverse. reflexivity. + Qed. + End Homomorphism. +End Field. + +(*** Tactics for manipulating field equations *) +Require Import Coq.setoid_ring.Field_tac. + +Ltac guess_field := + match goal with + | |- ?eq _ _ => constr:(_:field (eq:=eq)) + | |- not (?eq _ _) => constr:(_:field (eq:=eq)) + | [H: ?eq _ _ |- _ ] => constr:(_:field (eq:=eq)) + | [H: not (?eq _ _) |- _] => constr:(_:field (eq:=eq)) + end. + +Ltac common_denominator := + let fld := guess_field in + lazymatch type of fld with + field (div:=?div) => + lazymatch goal with + | |- appcontext[div] => field_simplify_eq + | |- _ => idtac + end + end. + +Ltac common_denominator_in H := + let fld := guess_field in + lazymatch type of fld with + field (div:=?div) => + lazymatch type of H with + | appcontext[div] => field_simplify_eq in H + | _ => idtac + end + end. + +Ltac common_denominator_all := + common_denominator; + repeat match goal with [H: _ |- _ _ _ ] => progress common_denominator_in H end. + +Inductive field_simplify_done {T} : T -> Type := + Field_simplify_done : forall H, field_simplify_done H. + +Ltac field_simplify_eq_hyps := + repeat match goal with + [ H: _ |- _ ] => + match goal with + | [ Ha : field_simplify_done H |- _ ] => fail + | _ => idtac + end; + field_simplify_eq in H; + unique pose proof (Field_simplify_done H) + end; + repeat match goal with [ H: field_simplify_done _ |- _] => clear H end. + +Ltac field_simplify_eq_all := field_simplify_eq_hyps; try field_simplify_eq. + + +(*** Polynomial equations over fields *) + +Ltac neq01 := + try solve + [apply zero_neq_one + |apply Group.zero_neq_opp_one + |apply one_neq_zero + |apply Group.opp_one_neq_zero]. + +Ltac field_algebra := + intros; + common_denominator_all; + try (nsatz; dropRingSyntax); + repeat (apply conj); + try solve + [neq01 + |trivial + |apply Ring.opp_nonzero_nonzero;trivial]. + +Section Example. + Context {F zero one opp add sub mul inv div} `{F_field:field F eq zero one opp add sub mul inv div}. + Local Infix "+" := add. Local Infix "*" := mul. Local Infix "-" := sub. Local Infix "/" := div. + Local Notation "0" := zero. Local Notation "1" := one. + + Add Field _ExampleField : (Field.field_theory_for_stdlib_tactic (T:=F)). + + Example _example_nsatz x y : 1+1 <> 0 -> x + y = 0 -> x - y = 0 -> x = 0. + Proof. field_algebra. Qed. + + Example _example_field_nsatz x y z : y <> 0 -> x/y = z -> z*y + y = x + y. + Proof. intros; subst; field_algebra. Qed. + + Example _example_nonzero_nsatz_contradict x y : x * y = 1 -> not (x = 0). + Proof. intros. intro. nsatz_contradict. Qed. +End Example. + +Section Z. + Require Import ZArith. + Global Instance ring_Z : @ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul. + Proof. repeat split; auto using Z.eq_dec with zarith typeclass_instances. Qed. + + Global Instance commutative_ring_Z : @commutative_ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul. + Proof. eauto using @commutative_ring, @is_commutative, ring_Z with zarith. Qed. + + Global Instance integral_domain_Z : @integral_domain Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul. + Proof. + split. + { apply commutative_ring_Z. } + { constructor. intros. apply Z.neq_mul_0; auto. } + { constructor. discriminate. } + Qed. + + Example _example_nonzero_nsatz_contradict_Z x y : Z.mul x y = (Zpos xH) -> not (x = Z0). + Proof. intros. intro. nsatz_contradict. Qed. +End Z. diff --git a/src/BaseSystem.v b/src/BaseSystem.v index e6ad55f18..c07aad759 100644 --- a/src/BaseSystem.v +++ b/src/BaseSystem.v @@ -1,7 +1,8 @@ Require Import Coq.Lists.List. -Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil. Require Import Coq.ZArith.ZArith Coq.ZArith.Zdiv. Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith. +Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil. +Import Nat. Local Open Scope Z. @@ -39,7 +40,7 @@ Section BaseSystem. Proof. unfold decode'; intros; f_equal; apply combine_truncate_l. Qed. - + Fixpoint add (us vs:digits) : digits := match us,vs with | u::us', v::vs' => u+v :: add us' vs' @@ -58,26 +59,26 @@ Section BaseSystem. | nil, v::vs' => (0-v)::sub nil vs' end. - Definition crosscoef i j : Z := + Definition crosscoef i j : Z := let b := nth_default 0 base in (b(i) * b(j)) / b(i+j)%nat. Hint Unfold crosscoef. Fixpoint zeros n := match n with O => nil | S n' => 0::zeros n' end. - + (* mul' is multiplication with the SECOND ARGUMENT REVERSED and OUTPUT REVERSED *) - Fixpoint mul_bi' (i:nat) (vsr:digits) := + Fixpoint mul_bi' (i:nat) (vsr:digits) := match vsr with | v::vsr' => v * crosscoef i (length vsr') :: mul_bi' i vsr' | nil => nil end. Definition mul_bi (i:nat) (vs:digits) : digits := zeros i ++ rev (mul_bi' i (rev vs)). - + (* mul' is multiplication with the FIRST ARGUMENT REVERSED *) Fixpoint mul' (usr vs:digits) : digits := match usr with - | u::usr' => + | u::usr' => mul_each u (mul_bi (length usr') vs) .+ mul' usr' vs | _ => nil end. @@ -87,7 +88,7 @@ End BaseSystem. (* Example : polynomial base system *) Section PolynomialBaseCoefs. - Context (b1 : positive) (baseLength : nat) (baseLengthNonzero : NPeano.ltb 0 baseLength = true). + Context (b1 : positive) (baseLength : nat) (baseLengthNonzero : ltb 0 baseLength = true). (** PolynomialBaseCoefs generates base vectors for [BaseSystem]. *) Definition bi i := (Zpos b1)^(Z.of_nat i). Definition poly_base := map bi (seq 0 baseLength). @@ -96,7 +97,7 @@ Section PolynomialBaseCoefs. unfold poly_base, bi, nth_default. case_eq baseLength; intros. { assert ((0 < baseLength)%nat) by - (rewrite <-NPeano.ltb_lt; apply baseLengthNonzero). + (rewrite <-ltb_lt; apply baseLengthNonzero). subst; omega. } auto. @@ -119,7 +120,7 @@ Section PolynomialBaseCoefs. Qed. Lemma poly_base_succ : - forall i, ((S i) < length poly_base)%nat -> + forall i, ((S i) < length poly_base)%nat -> let b := nth_default 0 poly_base in let r := (b (S i) / b i) in b (S i) = r * b i. @@ -127,7 +128,7 @@ Section PolynomialBaseCoefs. intros; subst b; subst r. repeat rewrite poly_base_defn in * by omega. unfold bi. - replace (Z.pos b1 ^ Z.of_nat (S i)) + replace (Z.pos b1 ^ Z.of_nat (S i)) with (Z.pos b1 * (Z.pos b1 ^ Z.of_nat i)) by (rewrite Nat2Z.inj_succ; rewrite <- Z.pow_succ_r; intuition). replace (Z.pos b1 * Z.pos b1 ^ Z.of_nat i / Z.pos b1 ^ Z.of_nat i) @@ -166,7 +167,7 @@ Import ListNotations. Section BaseSystemExample. Definition baseLength := 32%nat. - Lemma baseLengthNonzero : NPeano.ltb 0 baseLength = true. + Lemma baseLengthNonzero : ltb 0 baseLength = true. compute; reflexivity. Qed. Definition base2 := poly_base 2 baseLength. diff --git a/src/BaseSystemProofs.v b/src/BaseSystemProofs.v index ab56cb711..4414877b4 100644 --- a/src/BaseSystemProofs.v +++ b/src/BaseSystemProofs.v @@ -18,7 +18,7 @@ Section BaseSystemProofs. Qed. Lemma decode'_splice : forall xs ys bs, - decode' bs (xs ++ ys) = + decode' bs (xs ++ ys) = decode' (firstn (length xs) bs) xs + decode' (skipn (length xs) bs) ys. Proof. unfold decode'. @@ -83,7 +83,7 @@ Section BaseSystemProofs. unfold decode, encode; destruct z; boring. Qed. - Lemma mul_each_base : forall us bs c, + Lemma mul_each_base : forall us bs c, decode' bs (mul_each c us) = decode' (mul_each c bs) us. Proof. induction us; destruct bs; boring; ring. @@ -99,8 +99,8 @@ Section BaseSystemProofs. induction us; destruct low; boring. Qed. - Lemma base_mul_app : forall low c us, - decode' (low ++ mul_each c low) us = decode' low (firstn (length low) us) + + Lemma base_mul_app : forall low c us, + decode' (low ++ mul_each c low) us = decode' low (firstn (length low) us) + c * decode' low (skipn (length low) us). Proof. intros. @@ -118,7 +118,7 @@ Section BaseSystemProofs. Qed. Hint Rewrite length_zeros. - Lemma app_zeros_zeros : forall n m, zeros n ++ zeros m = zeros (n + m). + Lemma app_zeros_zeros : forall n m, zeros n ++ zeros m = zeros (n + m)%nat. Proof. induction n; boring. Qed. @@ -130,6 +130,18 @@ Section BaseSystemProofs. Qed. Hint Rewrite zeros_app0. + Lemma nth_default_zeros : forall n i, nth_default 0 (BaseSystem.zeros n) i = 0. + Proof. + induction n; intros; [ cbv [BaseSystem.zeros]; apply nth_default_nil | ]. + rewrite <-zeros_app0, nth_default_app. + rewrite length_zeros. + destruct (lt_dec i n); auto. + destruct (eq_nat_dec i n); subst. + + rewrite Nat.sub_diag; apply nth_default_cons. + + apply nth_default_out_of_bounds. + cbv [length]; omega. + Qed. + Lemma rev_zeros : forall n, rev (zeros n) = zeros n. Proof. induction n; boring. @@ -225,7 +237,7 @@ Section BaseSystemProofs. Lemma zeros_plus_zeros : forall n, zeros n = zeros n .+ zeros n. induction n; auto. - simpl; f_equal; auto. + simpl; f_equal; auto. Qed. Lemma mul_bi'_n_nil : forall n, mul_bi' base n nil = nil. @@ -243,13 +255,13 @@ Section BaseSystemProofs. induction us; auto. Qed. Hint Rewrite add_nil_r. - + Lemma add_first_terms : forall us vs a b, (a :: us) .+ (b :: vs) = (a + b) :: (us .+ vs). auto. Qed. Hint Rewrite add_first_terms. - + Lemma mul_bi'_cons : forall n x us, mul_bi' base n (x :: us) = x * crosscoef base n (length us) :: mul_bi' base n us. Proof. @@ -266,7 +278,7 @@ Section BaseSystemProofs. Hint Rewrite app_nil_l. Hint Rewrite app_nil_r. - Lemma add_snoc_same_length : forall l us vs a b, + Lemma add_snoc_same_length : forall l us vs a b, (length us = l) -> (length vs = l) -> (us ++ a :: nil) .+ (vs ++ b :: nil) = (us .+ vs) ++ (a + b) :: nil. Proof. @@ -276,7 +288,7 @@ Section BaseSystemProofs. Lemma mul_bi'_add : forall us n vs l (Hlus: length us = l) (Hlvs: length vs = l), - mul_bi' base n (rev (us .+ vs)) = + mul_bi' base n (rev (us .+ vs)) = mul_bi' base n (rev us) .+ mul_bi' base n (rev vs). Proof. (* TODO(adamc): please help prettify this *) @@ -310,7 +322,7 @@ Section BaseSystemProofs. Proof. induction n; boring. Qed. - + Lemma rev_add_rev : forall us vs l, (length us = l) -> (length vs = l) -> (rev us) .+ (rev vs) = rev (us .+ vs). Proof. @@ -352,7 +364,7 @@ Section BaseSystemProofs. Hint Rewrite minus_diag. Lemma add_trailing_zeros : forall us vs, (length us >= length vs)%nat -> - us .+ vs = us .+ (vs ++ (zeros (length us - length vs))). + us .+ vs = us .+ (vs ++ (zeros (length us - length vs)%nat)). Proof. induction us, vs; boring; f_equal; boring. Qed. @@ -377,8 +389,8 @@ Section BaseSystemProofs. induction us; boring. Qed. - Lemma sub_length_le_max : forall us vs, - (length (sub us vs) <= max (length us) (length vs))%nat. + Lemma sub_length : forall us vs, + (length (sub us vs) = max (length us) (length vs))%nat. Proof. induction us, vs; boring. rewrite sub_nil_length; auto. @@ -450,7 +462,7 @@ Section BaseSystemProofs. (* mul' is multiplication with the FIRST ARGUMENT REVERSED *) Fixpoint mul' (usr vs:digits) : digits := match usr with - | u::usr' => + | u::usr' => mul_each u (mul_bi base (length usr') vs) .+ mul' usr' vs | _ => nil end. @@ -499,5 +511,37 @@ Section BaseSystemProofs. rewrite rev_length; omega. Qed. + Lemma add_length_exact : forall us vs, + length (us .+ vs) = max (length us) (length vs). + Proof. + induction us; destruct vs; boring. + Qed. + + Lemma mul'_length_exact: forall us vs, + (length us <= length vs)%nat -> us <> nil -> + (length (mul' us vs) = pred (length us + length vs))%nat. + Proof. + induction us; intros; try solve [boring]. + unfold mul'; fold mul'. + unfold mul_each. + rewrite add_length_exact, map_length, mul_bi_length, length_cons. + destruct us. + + rewrite Max.max_0_r. simpl; omega. + + rewrite Max.max_l; [ omega | ]. + rewrite IHus by ( congruence || simpl in *; omega). + omega. + Qed. + + Lemma mul_length_exact: forall us vs, + (length us <= length vs)%nat -> us <> nil -> + (length (mul us vs) = pred (length us + length vs))%nat. + Proof. + intros; unfold mul. + rewrite mul'_length_exact; rewrite ?rev_length; try omega. + intro rev_nil. + match goal with H : us <> nil |- _ => apply H end. + apply length0_nil; rewrite <-rev_length, rev_nil. + reflexivity. + Qed. End BaseSystemProofs. diff --git a/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v b/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v index f70479c3a..683addd5d 100644 --- a/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v +++ b/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v @@ -1,47 +1,33 @@ Require Export Crypto.Spec.CompleteEdwardsCurve. -Require Import Crypto.ModularArithmetic.FField. -Require Import Crypto.ModularArithmetic.FNsatz. +Require Import Crypto.Algebra Crypto.Tactics.Nsatz. Require Import Crypto.CompleteEdwardsCurve.Pre. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. Require Import Coq.Logic.Eqdep_dec. Require Import Crypto.Tactics.VerdiTactics. +Require Import Coq.Classes.Morphisms. +Require Import Relation_Definitions. +Require Import Crypto.Util.Tuple. Module E. + Import Group Ring Field CompleteEdwardsCurve.E. Section CompleteEdwardsCurveTheorems. - Context {prm:TwistedEdwardsParams}. - Local Opaque q a d prime_q two_lt_q nonzero_a square_a nonsquare_d. (* [F_field] calls [compute] *) - Existing Instance prime_q. - - Add Field Ffield_p' : (@Ffield_theory q _) - (morphism (@Fring_morph q), - preprocess [Fpreprocess], - postprocess [Fpostprocess; try exact Fq_1_neq_0; try assumption], - constants [Fconstant], - div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). - - Add Field Ffield_notConstant : (OpaqueFieldTheory q) - (constants [notConstant]). - - Ltac clear_prm := - generalize dependent a; intro a; intros; - generalize dependent d; intro d; intros; - generalize dependent prime_q; intro prime_q; intros; - generalize dependent q; intro q; intros; - clear prm. - - Lemma point_eq : forall xy1 xy2 pf1 pf2, - xy1 = xy2 -> exist E.onCurve xy1 pf1 = exist E.onCurve xy2 pf2. - Proof. - destruct xy1, xy2; intros; find_injection; intros; subst. apply f_equal. - apply UIP_dec, F_eq_dec. (* this is a hack. We actually don't care about the equality of the proofs. However, we *can* prove it, and knowing it lets us use the universal equality instead of a type-specific equivalence, which makes many things nicer. *) - Qed. Hint Resolve point_eq. - - Definition point_eqb (p1 p2:E.point) : bool := andb - (F_eqb (fst (proj1_sig p1)) (fst (proj1_sig p2))) - (F_eqb (snd (proj1_sig p1)) (snd (proj1_sig p2))). - + Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv a d} + {field:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} + {prm:@twisted_edwards_params F Feq Fzero Fone Fadd Fmul a d}. + Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := Fzero. Local Notation "1" := Fone. + Local Infix "+" := Fadd. Local Infix "*" := Fmul. + Local Infix "-" := Fsub. Local Infix "/" := Fdiv. + Local Notation "x ^2" := (x*x) (at level 30). + Local Notation point := (@point F Feq Fone Fadd Fmul a d). + Local Notation onCurve := (@onCurve F Feq Fone Fadd Fmul a d). + + Add Field _edwards_curve_theorems_field : (field_theory_for_stdlib_tactic (H:=field)). + + Definition eq (P Q:point) := fieldwise (n:=2) Feq (coordinates P) (coordinates Q). + Infix "=" := eq : E_scope. + + (* TODO: decide whether we still want something like this, then port Local Ltac t := unfold point_eqb; repeat match goal with @@ -55,246 +41,190 @@ Module E. | [H: _ |- _ ] => apply F_eqb_eq in H | _ => rewrite F_eqb_refl end; eauto. - + Lemma point_eqb_sound : forall p1 p2, point_eqb p1 p2 = true -> p1 = p2. Proof. t. Qed. - + Lemma point_eqb_complete : forall p1 p2, p1 = p2 -> point_eqb p1 p2 = true. Proof. t. Qed. - + Lemma point_eqb_neq : forall p1 p2, point_eqb p1 p2 = false -> p1 <> p2. Proof. intros. destruct (point_eqb p1 p2) eqn:Hneq; intuition. apply point_eqb_complete in H0; congruence. Qed. - + Lemma point_eqb_neq_complete : forall p1 p2, p1 <> p2 -> point_eqb p1 p2 = false. Proof. intros. destruct (point_eqb p1 p2) eqn:Hneq; intuition. apply point_eqb_sound in Hneq. congruence. Qed. - + Lemma point_eqb_refl : forall p, point_eqb p p = true. Proof. t. Qed. - + Definition point_eq_dec (p1 p2:E.point) : {p1 = p2} + {p1 <> p2}. destruct (point_eqb p1 p2) eqn:H; match goal with | [ H: _ |- _ ] => apply point_eqb_sound in H | [ H: _ |- _ ] => apply point_eqb_neq in H end; eauto. Qed. - + Lemma point_eqb_correct : forall p1 p2, point_eqb p1 p2 = if point_eq_dec p1 p2 then true else false. Proof. intros. destruct (point_eq_dec p1 p2); eauto using point_eqb_complete, point_eqb_neq_complete. Qed. - - Ltac Edefn := unfold E.add, E.add', E.zero; intros; - repeat match goal with - | [ p : E.point |- _ ] => - let x := fresh "x" p in - let y := fresh "y" p in - let pf := fresh "pf" p in - destruct p as [[x y] pf]; unfold E.onCurve in pf - | _ => eapply point_eq, (f_equal2 pair) - | _ => eapply point_eq - end. - Lemma add_comm : forall A B, (A+B = B+A)%E. - Proof. - Edefn; apply (f_equal2 div); ring. - Qed. - - Ltac unifiedAdd_nonzero := match goal with - | [ |- (?op 1 (d * _ * _ * _ * _ * - inv (1 - d * ?xA * ?xB * ?yA * ?yB) * inv (1 + d * ?xA * ?xB * ?yA * ?yB)))%F <> 0%F] - => let Hadd := fresh "Hadd" in - pose proof (@unifiedAdd'_onCurve _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d (xA, yA) (xB, yB)) as Hadd; - simpl in Hadd; - match goal with - | [H : (1 - d * ?xC * xB * ?yC * yB)%F <> 0%F |- (?op 1 ?other)%F <> 0%F] => - replace other with - (d * xC * ((xA * yB + yA * xB) / (1 + d * xA * xB * yA * yB)) - * yC * ((yA * yB - a * xA * xB) / (1 - d * xA * xB * yA * yB)))%F by (subst; unfold div; ring); - auto - end - end. - - Lemma add_assoc : forall A B C, (A+(B+C) = (A+B)+C)%E. - Proof. - Edefn; F_field_simplify_eq; try abstract (rewrite ?@F_pow_2_r in *; clear_prm; F_nsatz); - pose proof (@edwardsAddCompletePlus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d); - pose proof (@edwardsAddCompleteMinus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d); - cbv beta iota in *; - repeat split; field_nonzero idtac; unifiedAdd_nonzero. - Qed. - - Lemma add_0_r : forall P, (P + E.zero = P)%E. - Proof. - Edefn; repeat rewrite ?F_add_0_r, ?F_add_0_l, ?F_sub_0_l, ?F_sub_0_r, - ?F_mul_0_r, ?F_mul_0_l, ?F_mul_1_l, ?F_mul_1_r, ?F_div_1_r; exact eq_refl. - Qed. + *) - Lemma add_0_l : forall P, (E.zero + P)%E = P. - Proof. - intros; rewrite add_comm. apply add_0_r. - Qed. + (* TODO: move to util *) + Lemma decide_and : forall P Q, {P}+{not P} -> {Q}+{not Q} -> {P/\Q}+{not(P/\Q)}. + Proof. intros; repeat match goal with [H:{_}+{_}|-_] => destruct H end; intuition. Qed. - Lemma mul_0_l : forall P, (0 * P = E.zero)%E. - Proof. - auto. - Qed. + Ltac destruct_points := + repeat match goal with + | [ p : point |- _ ] => + let x := fresh "x" p in + let y := fresh "y" p in + let pf := fresh "pf" p in + destruct p as [[x y] pf] + end. - Lemma mul_S_l : forall n P, (S n * P)%E = (P + n * P)%E. - Proof. - auto. - Qed. + Ltac expand_opp := + rewrite ?mul_opp_r, ?mul_opp_l, ?ring_sub_definition, ?inv_inv, <-?ring_sub_definition. - Lemma mul_add_l : forall a b P, ((a + b)%nat * P)%E = E.add (a * P)%E (b * P)%E. - Proof. - induction a; intros; rewrite ?plus_Sn_m, ?plus_O_n, ?mul_S_l, ?mul_0_l, ?add_0_l, ?mul_S_, ?IHa, ?add_assoc; auto. - Qed. + Local Hint Resolve char_gt_2. + Local Hint Resolve nonzero_a. + Local Hint Resolve square_a. + Local Hint Resolve nonsquare_d. + Local Hint Resolve @edwardsAddCompletePlus. + Local Hint Resolve @edwardsAddCompleteMinus. - Lemma mul_assoc : forall (n m : nat) P, (n * (m * P) = (n * m)%nat * P)%E. - Proof. - induction n; intros; auto. - rewrite ?mul_S_l, ?Mult.mult_succ_l, ?mul_add_l, ?IHn, add_comm. reflexivity. - Qed. + Local Obligation Tactic := intros; destruct_points; simpl; field_algebra. + Program Definition opp (P:point) : point := + exist _ (let '(x, y) := coordinates P in (Fopp x, y) ) _. - Lemma mul_zero_r : forall m, (m * E.zero = E.zero)%E. - Proof. - induction m; rewrite ?mul_S_l, ?add_0_l; auto. - Qed. - - (* solve for x ^ 2 *) - Definition solve_for_x2 (y : F q) := ((y ^ 2 - 1) / (d * (y ^ 2) - a))%F. - - Lemma d_y2_a_nonzero : (forall y, 0 <> d * y ^ 2 - a)%F. - intros ? eq_zero. - pose proof prime_q. - destruct square_a as [sqrt_a sqrt_a_id]. - rewrite <- sqrt_a_id in eq_zero. - destruct (Fq_square_mul_sub _ _ _ eq_zero) as [ [sqrt_d sqrt_d_id] | a_zero]. - + pose proof (nonsquare_d sqrt_d); auto. - + subst. - rewrite Fq_pow_zero in sqrt_a_id by congruence. - auto using nonzero_a. - Qed. - - Lemma a_d_y2_nonzero : (forall y, a - d * y ^ 2 <> 0)%F. - Proof. - intros y eq_zero. - pose proof prime_q. - eapply F_minus_swap in eq_zero. - eauto using (d_y2_a_nonzero y). - Qed. - - Lemma solve_correct : forall x y, E.onCurve (x, y) <-> - (x ^ 2 = solve_for_x2 y)%F. - Proof. - split. - + intro onCurve_x_y. - pose proof prime_q. - unfold E.onCurve in onCurve_x_y. - eapply F_div_mul; auto using (d_y2_a_nonzero y). - replace (x ^ 2 * (d * y ^ 2 - a))%F with ((d * x ^ 2 * y ^ 2) - (a * x ^ 2))%F by ring. - rewrite F_sub_add_swap. - replace (y ^ 2 + a * x ^ 2)%F with (a * x ^ 2 + y ^ 2)%F by ring. - rewrite onCurve_x_y. - ring. - + intro x2_eq. - unfold E.onCurve, solve_for_x2 in *. - rewrite x2_eq. - field. - auto using d_y2_a_nonzero. - Qed. - - - Program Definition opp (P:E.point) : E.point := let '(x, y) := proj1_sig P in (opp x, y). - Next Obligation. Proof. - pose (proj2_sig P) as H; rewrite <-Heq_anonymous in H; simpl in H. - rewrite F_square_opp; trivial. - Qed. - - Definition sub P Q := (P + opp Q)%E. - - Lemma opp_zero : opp E.zero = E.zero. - Proof. - pose proof @F_opp_0. - unfold opp, E.zero; eapply point_eq; congruence. - Qed. - - Lemma add_opp_r : forall P, (P + opp P = E.zero)%E. - Proof. - unfold opp; Edefn; rewrite ?@F_pow_2_r in *; (F_field_simplify_eq; [clear_prm; F_nsatz|..]); - rewrite <-?@F_pow_2_r in *; - pose proof (@edwardsAddCompletePlus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d _ _ _ _ pfP pfP); - pose proof (@edwardsAddCompleteMinus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d _ _ _ _ pfP pfP); - field_nonzero idtac. - Qed. - - Lemma add_opp_l : forall P, (opp P + P = E.zero)%E. - Proof. - intros. rewrite add_comm. eapply add_opp_r. - Qed. - - Lemma add_cancel_r : forall A B C, (B+A = C+A -> B = C)%E. - Proof. - intros. - assert ((B + A) + opp A = (C + A) + opp A)%E as Hc by congruence. - rewrite <-!add_assoc, !add_opp_r, !add_0_r in Hc; exact Hc. - Qed. - - Lemma add_cancel_l : forall A B C, (A+B = A+C -> B = C)%E. - Proof. - intros. - rewrite (add_comm A C) in H. - rewrite (add_comm A B) in H. - eauto using add_cancel_r. - Qed. - - Lemma shuffle_eq_add_opp : forall P Q R, (P + Q = R <-> Q = opp P + R)%E. - Proof. - split; intros. - { assert (opp P + (P + Q) = opp P + R)%E as Hc by congruence. - rewrite add_assoc, add_opp_l, add_comm, add_0_r in Hc; exact Hc. } - { subst. rewrite add_assoc, add_opp_r, add_comm, add_0_r; reflexivity. } - Qed. - - Lemma opp_opp : forall P, opp (opp P) = P. - Proof. - intros. - pose proof (add_opp_r P%E) as H. - rewrite add_comm in H. - rewrite shuffle_eq_add_opp in H. - rewrite add_0_r in H. - congruence. - Qed. - - Lemma opp_add : forall P Q, opp (P + Q)%E = (opp P + opp Q)%E. + Ltac bash_step := + match goal with + | |- _ => progress intros + | [H: _ /\ _ |- _ ] => destruct H + | |- _ => progress destruct_points + | |- _ => progress cbv [fst snd coordinates proj1_sig eq fieldwise fieldwise' add zero opp] in * + | |- _ => split + | |- Feq _ _ => field_algebra + | |- _ <> 0 => expand_opp; solve [nsatz_nonzero|eauto 6] + | |- {_}+{_} => eauto 15 using decide_and, @eq_dec with typeclass_instances + end. + + Ltac bash := repeat bash_step. + + Global Instance Proper_add : Proper (eq==>eq==>eq) add. Proof. bash. Qed. + Global Instance Proper_opp : Proper (eq==>eq) opp. Proof. bash. Qed. + Global Instance Proper_coordinates : Proper (eq==>fieldwise (n:=2) Feq) coordinates. Proof. bash. Qed. + + Global Instance edwards_acurve_abelian_group : abelian_group (eq:=eq)(op:=add)(id:=zero)(inv:=opp). + Proof. + bash. + (* TODO: port denominator-nonzero proofs for associativity *) + match goal with | |- _ <> 0 => admit end. + match goal with | |- _ <> 0 => admit end. + match goal with | |- _ <> 0 => admit end. + match goal with | |- _ <> 0 => admit end. + Admitted. + + (* TODO: move to [Group] and [AbelianGroup] as appropriate *) + Lemma mul_0_l : forall P, (0 * P = zero)%E. + Proof. intros; reflexivity. Qed. + Lemma mul_S_l : forall n P, (S n * P = P + n * P)%E. + Proof. intros; reflexivity. Qed. + Lemma mul_add_l : forall (n m:nat) (P:point), ((n + m)%nat * P = n * P + m * P)%E. Proof. - intros. - pose proof (add_opp_r (P+Q)%E) as H. - rewrite <-!add_assoc in H. - rewrite add_comm in H. - rewrite <-!add_assoc in H. - rewrite shuffle_eq_add_opp in H. - rewrite add_comm in H. - rewrite shuffle_eq_add_opp in H. - rewrite add_0_r in H. - assumption. + induction n; intros; + rewrite ?plus_Sn_m, ?plus_O_n, ?mul_S_l, ?left_identity, <-?associative, <-?IHn; reflexivity. Qed. - - Lemma opp_mul : forall n P, opp (E.mul n P) = E.mul n (opp P). + Lemma mul_assoc : forall (n m : nat) P, (n * (m * P) = (n * m)%nat * P)%E. Proof. - pose proof opp_add; pose proof opp_zero. - induction n; simpl; intros; congruence. + induction n; intros; [reflexivity|]. + rewrite ?mul_S_l, ?Mult.mult_succ_l, ?mul_add_l, ?IHn, commutative; reflexivity. Qed. + Lemma mul_zero_r : forall m, (m * E.zero = E.zero)%E. + Proof. induction m; rewrite ?mul_S_l, ?left_identity, ?IHm; try reflexivity. Qed. + Lemma opp_mul : forall n P, (opp (n * P) = n * (opp P))%E. + Admitted. + + Section PointCompression. + Local Notation "x ^2" := (x*x). + Definition solve_for_x2 (y : F) := ((y^2 - 1) / (d * (y^2) - a)). + + Lemma a_d_y2_nonzero : forall y, d * y^2 - a <> 0. + Proof. + intros ? eq_zero. + destruct square_a as [sqrt_a sqrt_a_id]; rewrite <- sqrt_a_id in eq_zero. + destruct (eq_dec y 0); [apply nonzero_a|apply nonsquare_d with (sqrt_a/y)]; field_algebra. + Qed. + + Lemma solve_correct : forall x y, onCurve (x, y) <-> (x^2 = solve_for_x2 y). + Proof. + unfold solve_for_x2; simpl; split; intros; field_algebra; auto using a_d_y2_nonzero. + Qed. + End PointCompression. End CompleteEdwardsCurveTheorems. + + Section Homomorphism. + Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv Fa Fd} + {fieldF:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} + {Fprm:@twisted_edwards_params F Feq Fzero Fone Fadd Fmul Fa Fd}. + Context {K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv Ka Kd} + {fieldK:@field K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv} + {Kprm:@twisted_edwards_params K Keq Kzero Kone Kadd Kmul Ka Kd}. + Context {phi:F->K} {Hphi:@Ring.is_homomorphism F Feq Fone Fadd Fmul + K Keq Kone Kadd Kmul phi}. + Context {Ha:Keq (phi Fa) Ka} {Hd:Keq (phi Fd) Kd}. + Local Notation Fpoint := (@point F Feq Fone Fadd Fmul Fa Fd). + Local Notation Kpoint := (@point K Keq Kone Kadd Kmul Ka Kd). + + Create HintDb field_homomorphism discriminated. + Hint Rewrite <- + homomorphism_one + homomorphism_add + homomorphism_sub + homomorphism_mul + homomorphism_div + Ha + Hd + : field_homomorphism. + + Program Definition ref_phi (P:Fpoint) : Kpoint := exist _ ( + let (x, y) := coordinates P in (phi x, phi y)) _. + Next Obligation. + destruct P as [[? ?] ?]; simpl. + rewrite_strat bottomup hints field_homomorphism. + eauto using is_homomorphism_phi_proper; assumption. + Qed. + + Context {point_phi:Fpoint->Kpoint} + {point_phi_Proper:Proper (eq==>eq) point_phi} + {point_phi_correct: forall (P:Fpoint), eq (point_phi P) (ref_phi P)}. + + Lemma lift_homomorphism : @Group.is_homomorphism Fpoint eq add Kpoint eq add point_phi. + Proof. + repeat match goal with + | |- Group.is_homomorphism => split + | |- _ => intro + | |- _ /\ _ => split + | [H: _ /\ _ |- _ ] => destruct H + | [p: point |- _ ] => destruct p as [[??]?] + | |- context[point_phi] => setoid_rewrite point_phi_correct + | |- _ => progress cbv [fst snd coordinates proj1_sig eq fieldwise fieldwise' add zero opp ref_phi] in * + | |- Keq ?x ?x => reflexivity + | |- Keq ?x ?y => rewrite_strat bottomup hints field_homomorphism + | [ H : Feq _ _ |- Keq (phi _) (phi _)] => solve [f_equiv; intuition] + end. + Qed. + End Homomorphism. End E. -Infix "-" := E.sub : E_scope.
\ No newline at end of file diff --git a/src/CompleteEdwardsCurve/DoubleAndAdd.v b/src/CompleteEdwardsCurve/DoubleAndAdd.v deleted file mode 100644 index 50027349d..000000000 --- a/src/CompleteEdwardsCurve/DoubleAndAdd.v +++ /dev/null @@ -1,30 +0,0 @@ -Require Import Crypto.Tactics.VerdiTactics. -Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.Util.IterAssocOp. -Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Coq.Numbers.BinNums Coq.NArith.NArith Coq.NArith.Nnat Coq.ZArith.ZArith. - -Section EdwardsDoubleAndAdd. - Context {prm:TwistedEdwardsParams}. - Definition doubleAndAdd (bound n : nat) (P : E.point) : E.point := - iter_op E.add E.zero N.testbit_nat (N.of_nat n) P bound. - - Lemma scalarMult_double : forall n P, E.mul (n + n) P = E.mul n (P + P)%E. - Proof. - intros. - replace (n + n)%nat with (n * 2)%nat by omega. - induction n; simpl; auto. - rewrite E.add_assoc. - f_equal; auto. - Qed. - - Lemma doubleAndAdd_spec : forall bound n P, N.size_nat (N.of_nat n) <= bound -> - E.mul n P = doubleAndAdd bound n P. - Proof. - induction n; auto; intros; unfold doubleAndAdd; - rewrite iter_op_spec with (scToN := fun x => x); ( - unfold Morphisms.Proper, Morphisms.respectful, Equivalence.equiv; - intros; subst; try rewrite Nat2N.id; - reflexivity || assumption || apply E.add_assoc - || rewrite E.add_comm; apply E.add_0_r). - Qed. -End EdwardsDoubleAndAdd.
\ No newline at end of file diff --git a/src/CompleteEdwardsCurve/ExtendedCoordinates.v b/src/CompleteEdwardsCurve/ExtendedCoordinates.v index e91bc084b..25af83a0a 100644 --- a/src/CompleteEdwardsCurve/ExtendedCoordinates.v +++ b/src/CompleteEdwardsCurve/ExtendedCoordinates.v @@ -1,194 +1,154 @@ -Require Import Crypto.CompleteEdwardsCurve.Pre. -Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Require Import Crypto.ModularArithmetic.FField. -Require Import Crypto.Tactics.VerdiTactics. -Require Import Util.IterAssocOp BinNat NArith. -Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Classes.Equivalence. -Local Open Scope equiv_scope. -Local Open Scope F_scope. - -Section ExtendedCoordinates. - Context {prm:TwistedEdwardsParams}. - Local Opaque q a d prime_q two_lt_q nonzero_a square_a nonsquare_d. (* [F_field] calls [compute] *) - Existing Instance prime_q. - - Add Field Ffield_p' : (@Ffield_theory q _) - (morphism (@Fring_morph q), - preprocess [Fpreprocess], - postprocess [Fpostprocess; try exact Fq_1_neq_0; try assumption], - constants [Fconstant], - div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). - - Add Field Ffield_notConstant : (OpaqueFieldTheory q) - (constants [notConstant]). - - (** [extended] represents a point on an elliptic curve using extended projective - * Edwards coordinates with twist a=-1 (see <https://eprint.iacr.org/2008/522.pdf>). *) - Record extended := mkExtended {extendedX : F q; - extendedY : F q; - extendedZ : F q; - extendedT : F q}. - Local Notation "'(' X ',' Y ',' Z ',' T ')'" := (mkExtended X Y Z T). - - Definition twistedToExtended (P : (F q*F q)) : extended := - let '(x, y) := P in (x, y, 1, x*y). - Definition extendedToTwisted (P : extended) : F q * F q := - let '(X, Y, Z, T) := P in ((X/Z), (Y/Z)). - Definition rep (P:extended) (rP:(F q*F q)) : Prop := - let '(X, Y, Z, T) := P in - extendedToTwisted P = rP /\ - Z <> 0 /\ - T = X*Y/Z. - Local Hint Unfold twistedToExtended extendedToTwisted rep. - Local Notation "P '~=' rP" := (rep P rP) (at level 70). - - Ltac unfoldExtended := - repeat progress (autounfold; unfold E.onCurve, E.add, E.add', rep in *; intros); - repeat match goal with - | [ p : (F q*F q)%type |- _ ] => - let x := fresh "x" p in - let y := fresh "y" p in - destruct p as [x y] - | [ p : extended |- _ ] => - let X := fresh "X" p in - let Y := fresh "Y" p in - let Z := fresh "Z" p in - let T := fresh "T" p in - destruct p as [X Y Z T] - | [ H: _ /\ _ |- _ ] => destruct H - | [ H: @eq (F q * F q)%type _ _ |- _ ] => invcs H - | [ H: @eq F q ?x _ |- _ ] => isVar x; rewrite H; clear H - end. - - Ltac solveExtended := unfoldExtended; - repeat match goal with - | [ |- _ /\ _ ] => split - | [ |- @eq (F q * F q)%type _ _] => apply f_equal2 - | _ => progress rewrite ?@F_add_0_r, ?@F_add_0_l, ?@F_sub_0_l, ?@F_sub_0_r, - ?@F_mul_0_r, ?@F_mul_0_l, ?@F_mul_1_l, ?@F_mul_1_r, ?@F_div_1_r - | _ => solve [eapply @Fq_1_neq_0; eauto with typeclass_instances] - | _ => solve [eauto with typeclass_instances] - | [ H: a = _ |- _ ] => rewrite H - end. - - Lemma twistedToExtended_rep : forall P, twistedToExtended P ~= P. - Proof. - solveExtended. - Qed. - - Lemma extendedToTwisted_rep : forall P rP, P ~= rP -> extendedToTwisted P = rP. - Proof. - solveExtended. - Qed. - - Definition extendedPoint := { P:extended | rep P (extendedToTwisted P) /\ E.onCurve (extendedToTwisted P) }. - - Program Definition mkExtendedPoint : E.point -> extendedPoint := twistedToExtended. - Next Obligation. - destruct x; erewrite extendedToTwisted_rep; eauto using twistedToExtended_rep. - Qed. - - Program Definition unExtendedPoint : extendedPoint -> E.point := extendedToTwisted. - Next Obligation. - destruct x; simpl; intuition. - Qed. - - Definition extendedPoint_eq P Q := unExtendedPoint P = unExtendedPoint Q. - Global Instance Equivalence_extendedPoint_eq : Equivalence extendedPoint_eq. - Proof. - repeat (econstructor || intro); unfold extendedPoint_eq in *; congruence. - Qed. - - Lemma unExtendedPoint_mkExtendedPoint : forall P, unExtendedPoint (mkExtendedPoint P) = P. - Proof. - destruct P; eapply E.point_eq; simpl; erewrite extendedToTwisted_rep; eauto using twistedToExtended_rep. - Qed. - - Global Instance Proper_mkExtendedPoint : Proper (eq==>equiv) mkExtendedPoint. - Proof. - repeat (econstructor || intro); unfold extendedPoint_eq in *; congruence. - Qed. - - Global Instance Proper_unExtendedPoint : Proper (equiv==>eq) unExtendedPoint. - Proof. - repeat (econstructor || intro); unfold extendedPoint_eq in *; congruence. - Qed. - - Definition twice_d := d + d. - - Section TwistMinus1. - Context (a_eq_minus1 : a = opp 1). - (** Second equation from <http://eprint.iacr.org/2008/522.pdf> section 3.1, also <https://www.hyperelliptic.org/EFD/g1p/auto-twisted-extended-1.html#addition-add-2008-hwcd-3> and <https://tools.ietf.org/html/draft-josefsson-eddsa-ed25519-03> *) - Definition unifiedAddM1' (P1 P2 : extended) : extended := - let '(X1, Y1, Z1, T1) := P1 in - let '(X2, Y2, Z2, T2) := P2 in - let A := (Y1-X1)*(Y2-X2) in - let B := (Y1+X1)*(Y2+X2) in - let C := T1*twice_d*T2 in - let D := Z1*(Z2+Z2) in - let E := B-A in - let F := D-C in - let G := D+C in - let H := B+A in - let X3 := E*F in - let Y3 := G*H in - let T3 := E*H in - let Z3 := F*G in - (X3, Y3, Z3, T3). - Local Hint Unfold E.add. - - Local Ltac tnz := repeat apply Fq_mul_nonzero_nonzero; auto using (@char_gt_2 q two_lt_q). - - Lemma F_mul_2_l : forall x : F q, ZToField 2 * x = x + x. - intros. ring. - Qed. - - Lemma unifiedAddM1'_rep: forall P Q rP rQ, E.onCurve rP -> E.onCurve rQ -> - P ~= rP -> Q ~= rQ -> (unifiedAddM1' P Q) ~= (E.add' rP rQ). - Proof. - intros P Q rP rQ HoP HoQ HrP HrQ. - pose proof (@edwardsAddCompletePlus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d). - pose proof (@edwardsAddCompleteMinus _ _ _ _ two_lt_q nonzero_a square_a nonsquare_d). - unfoldExtended; unfold twice_d; rewrite a_eq_minus1 in *; simpl in *. repeat rewrite <-F_mul_2_l. - repeat split; repeat apply (f_equal2 pair); try F_field; repeat split; auto; - repeat rewrite ?F_add_0_r, ?F_add_0_l, ?F_sub_0_l, ?F_sub_0_r, - ?F_mul_0_r, ?F_mul_0_l, ?F_mul_1_l, ?F_mul_1_r, ?F_div_1_r; - field_nonzero tnz. - Qed. - - Lemma unifiedAdd'_onCurve : forall P Q, E.onCurve P -> E.onCurve Q -> E.onCurve (E.add' P Q). - Proof. - intros; pose proof (proj2_sig (E.add (exist _ _ H) (exist _ _ H0))); eauto. - Qed. - - Program Definition unifiedAddM1 : extendedPoint -> extendedPoint -> extendedPoint := unifiedAddM1'. - Next Obligation. - destruct x, x0; simpl; intuition. - - erewrite extendedToTwisted_rep; eauto using unifiedAddM1'_rep. - - erewrite extendedToTwisted_rep. - (* It would be nice if I could use eauto here, but it gets evars wrong :( *) - 2: eapply unifiedAddM1'_rep. 5:apply H1. 4:apply H. 3:auto. 2:auto. - eauto using unifiedAdd'_onCurve. - Qed. - - Lemma unifiedAddM1_rep : forall P Q, E.add (unExtendedPoint P) (unExtendedPoint Q) = unExtendedPoint (unifiedAddM1 P Q). - Proof. - destruct P, Q; unfold unExtendedPoint, E.add, unifiedAddM1; eapply E.point_eq; simpl in *; intuition. - pose proof (unifiedAddM1'_rep x x0 (extendedToTwisted x) (extendedToTwisted x0)); - destruct (unifiedAddM1' x x0); - unfold rep in *; intuition. - Qed. - - Global Instance Proper_unifiedAddM1 : Proper (equiv==>equiv==>equiv) unifiedAddM1. - Proof. - repeat (econstructor || intro). - repeat match goal with [H: _ === _ |- _ ] => inversion H; clear H end; unfold equiv, extendedPoint_eq. - rewrite <-!unifiedAddM1_rep. - destruct x, y, x0, y0; simpl in *; eapply E.point_eq; congruence. - Qed. +Require Export Crypto.Spec.CompleteEdwardsCurve. +Require Import Crypto.Algebra Crypto.Tactics.Nsatz. +Require Import Crypto.CompleteEdwardsCurve.Pre Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. +Require Import Coq.Logic.Eqdep_dec. +Require Import Crypto.Tactics.VerdiTactics. +Require Import Coq.Classes.Morphisms. +Require Import Relation_Definitions. +Require Import Crypto.Util.Tuple. + +Module Extended. + Section ExtendedCoordinates. + Import Group Ring Field. + Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv a d} + {field:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} + {prm:@E.twisted_edwards_params F Feq Fzero Fone Fadd Fmul a d}. + Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := Fzero. Local Notation "1" := Fone. + Local Infix "+" := Fadd. Local Infix "*" := Fmul. + Local Infix "-" := Fsub. Local Infix "/" := Fdiv. + Local Notation "x ^2" := (x*x) (at level 30). + Local Notation Epoint := (@E.point F Feq Fone Fadd Fmul a d). + Local Notation onCurve := (@Pre.onCurve F Feq Fone Fadd Fmul a d). + + Add Field _edwards_curve_extended_field : (field_theory_for_stdlib_tactic (H:=field)). + + (** [Extended.point] represents a point on an elliptic curve using extended projective + * Edwards coordinates with twist a=-1 (see <https://eprint.iacr.org/2008/522.pdf>). *) + Definition point := { P | let '(X,Y,Z,T) := P in onCurve((X/Z), (Y/Z)) /\ Z<>0 /\ Z*T=X*Y }. + Definition coordinates (P:point) : F*F*F*F := proj1_sig P. + + Create HintDb bash discriminated. + Local Hint Unfold E.eq fst snd fieldwise fieldwise' coordinates E.coordinates proj1_sig Pre.onCurve : bash. + Ltac bash := + repeat match goal with + | |- Proper _ _ => intro + | _ => progress intros + | [ H: _ /\ _ |- _ ] => destruct H + | [ p:E.point |- _ ] => destruct p as [[??]?] + | [ p:point |- _ ] => destruct p as [[[[??]?]?]?] + | _ => progress autounfold with bash in * + | |- _ /\ _ => split + | _ => solve [neq01] + | _ => solve [eauto] + | _ => solve [intuition] + | _ => solve [etransitivity; eauto] + | |- Feq _ _ => field_algebra + | |- _ <> 0 => apply mul_nonzero_nonzero + | [ H : _ <> 0 |- _ <> 0 ] => + intro; apply H; + field_algebra; + solve [ apply Ring.opp_nonzero_nonzero, E.char_gt_2 + | apply E.char_gt_2] + end. + + Obligation Tactic := bash. + + Program Definition from_twisted (P:Epoint) : point := exist _ + (let (x,y) := E.coordinates P in (x, y, 1, x*y)) _. + + Program Definition to_twisted (P:point) : Epoint := exist _ + (let '(X,Y,Z,T) := coordinates P in ((X/Z), (Y/Z))) _. + + Definition eq (P Q:point) := E.eq (to_twisted P) (to_twisted Q). + + Local Hint Unfold from_twisted to_twisted eq : bash. + + Global Instance Equivalence_eq : Equivalence eq. Proof. split; split; bash. Qed. + Global Instance Proper_from_twisted : Proper (E.eq==>eq) from_twisted. Proof. bash. Qed. + Global Instance Proper_to_twisted : Proper (eq==>E.eq) to_twisted. Proof. bash. Qed. + Lemma to_twisted_from_twisted P : E.eq (to_twisted (from_twisted P)) P. Proof. bash. Qed. + + Section TwistMinus1. + Context {a_eq_minus1 : a = Fopp 1}. + Context {twice_d:F} {Htwice_d:twice_d = d + d}. + (** Second equation from <http://eprint.iacr.org/2008/522.pdf> section 3.1, also <https://www.hyperelliptic.org/EFD/g1p/auto-twisted-extended-1.html#addition-add-2008-hwcd-3> and <https://tools.ietf.org/html/draft-josefsson-eddsa-ed25519-03> *) + Definition add_coordinates P1 P2 : F*F*F*F := + let '(X1, Y1, Z1, T1) := P1 in + let '(X2, Y2, Z2, T2) := P2 in + let A := (Y1-X1)*(Y2-X2) in + let B := (Y1+X1)*(Y2+X2) in + let C := T1*twice_d*T2 in + let D := Z1*(Z2+Z2) in + let E := B-A in + let F := D-C in + let G := D+C in + let H := B+A in + let X3 := E*F in + let Y3 := G*H in + let T3 := E*H in + let Z3 := F*G in + (X3, Y3, Z3, T3). + + Local Hint Unfold E.add E.coordinates add_coordinates : bash. + + Lemma add_coordinates_correct (P Q:point) : + let '(X,Y,Z,T) := add_coordinates (coordinates P) (coordinates Q) in + let (x, y) := E.coordinates (E.add (to_twisted P) (to_twisted Q)) in + (fieldwise (n:=2) Feq) (x, y) (X/Z, Y/Z). + Proof. + destruct P as [[[[]?]?][HP []]]; destruct Q as [[[[]?]?][HQ []]]. + pose proof edwardsAddCompletePlus (a_nonzero:=E.nonzero_a)(a_square:=E.square_a)(d_nonsquare:=E.nonsquare_d)(char_gt_2:=E.char_gt_2) _ _ _ _ HP HQ. + pose proof edwardsAddCompleteMinus (a_nonzero:=E.nonzero_a)(a_square:=E.square_a)(d_nonsquare:=E.nonsquare_d)(char_gt_2:=E.char_gt_2) _ _ _ _ HP HQ. + bash. + Qed. + + Obligation Tactic := idtac. + Program Definition add (P Q:point) : point := add_coordinates (coordinates P) (coordinates Q). + Next Obligation. + intros. + pose proof (add_coordinates_correct P Q) as Hrep. + pose proof Pre.unifiedAdd'_onCurve(a_nonzero:=E.nonzero_a)(a_square:=E.square_a)(d_nonsquare:=E.nonsquare_d)(char_gt_2:=E.char_gt_2) (E.coordinates (to_twisted P)) (E.coordinates (to_twisted Q)) as Hon. + destruct P as [[[[]?]?][HP []]]; destruct Q as [[[[]?]?][HQ []]]. + pose proof edwardsAddCompletePlus (a_nonzero:=E.nonzero_a)(a_square:=E.square_a)(d_nonsquare:=E.nonsquare_d)(char_gt_2:=E.char_gt_2) _ _ _ _ HP HQ as Hnz1. + pose proof edwardsAddCompleteMinus (a_nonzero:=E.nonzero_a)(a_square:=E.square_a)(d_nonsquare:=E.nonsquare_d)(char_gt_2:=E.char_gt_2) _ _ _ _ HP HQ as Hnz2. + autounfold with bash in *; simpl in *. + destruct Hrep as [HA HB]. rewrite <-!HA, <-!HB; clear HA HB. + bash. + Qed. + Local Hint Unfold add : bash. + + Lemma to_twisted_add P Q : E.eq (to_twisted (add P Q)) (E.add (to_twisted P) (to_twisted Q)). + Proof. + pose proof (add_coordinates_correct P Q) as Hrep. + destruct P as [[[[]?]?][HP []]]; destruct Q as [[[[]?]?][HQ []]]. + autounfold with bash in *; simpl in *. + destruct Hrep as [HA HB]. rewrite <-!HA, <-!HB; clear HA HB. + split; reflexivity. + Qed. + + Global Instance Proper_add : Proper (eq==>eq==>eq) add. + Proof. + unfold eq. intros x y H x0 y0 H0. + transitivity (to_twisted x + to_twisted x0)%E; rewrite to_twisted_add, ?H, ?H0; reflexivity. + Qed. + + Lemma homomorphism_to_twisted : @Group.is_homomorphism point eq add Epoint E.eq E.add to_twisted. + Proof. split; trivial using Proper_to_twisted, to_twisted_add. Qed. + + Lemma add_from_twisted P Q : eq (from_twisted (P + Q)%E) (add (from_twisted P) (from_twisted Q)). + Proof. + pose proof (to_twisted_add (from_twisted P) (from_twisted Q)). + unfold eq; rewrite !to_twisted_from_twisted in *. + symmetry; assumption. + Qed. + + Lemma homomorphism_from_twisted : @Group.is_homomorphism Epoint E.eq E.add point eq add from_twisted. + Proof. split; trivial using Proper_from_twisted, add_from_twisted. Qed. + + (* TODO: decide whether we still need those, then port *) + (* Lemma unifiedAddM1_0_r : forall P, unifiedAddM1 P (mkExtendedPoint E.zero) === P. unfold equiv, extendedPoint_eq; intros. rewrite <-!unifiedAddM1_rep, unExtendedPoint_mkExtendedPoint, E.add_0_r; auto. @@ -210,30 +170,75 @@ Section ExtendedCoordinates. trivial. Qed. - Definition scalarMultM1 := iter_op unifiedAddM1 (mkExtendedPoint E.zero) N.testbit_nat. - Definition scalarMultM1_spec := - iter_op_spec unifiedAddM1 unifiedAddM1_assoc (mkExtendedPoint E.zero) unifiedAddM1_0_l - N.testbit_nat (fun x => x) testbit_conversion_identity. - Lemma scalarMultM1_rep : forall n P, unExtendedPoint (scalarMultM1 (N.of_nat n) P (N.size_nat (N.of_nat n))) = E.mul n (unExtendedPoint P). - intros; rewrite scalarMultM1_spec, Nat2N.id; auto. - induction n; [simpl; rewrite !unExtendedPoint_mkExtendedPoint; reflexivity|]. + Lemma scalarMultM1_rep : forall n P, unExtendedPoint (nat_iter_op unifiedAddM1 (mkExtendedPoint E.zero) n P) = E.mul n (unExtendedPoint P). + induction n; [simpl; rewrite !unExtendedPoint_mkExtendedPoint; reflexivity|]; intros. unfold E.mul; fold E.mul. rewrite <-IHn, unifiedAddM1_rep; auto. Qed. + *) + End TwistMinus1. + End ExtendedCoordinates. + + Section Homomorphism. + Import Group Ring Field. + Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv Fa Fd} + {fieldF:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} + {Fprm:@E.twisted_edwards_params F Feq Fzero Fone Fadd Fmul Fa Fd}. + Context {K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv Ka Kd} + {fieldK:@field K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv} + {Kprm:@E.twisted_edwards_params K Keq Kzero Kone Kadd Kmul Ka Kd}. + Context {phi:F->K} {Hphi:@Ring.is_homomorphism F Feq Fone Fadd Fmul + K Keq Kone Kadd Kmul phi}. + Context {phi_nonzero : forall x, ~ Feq x Fzero -> ~ Keq (phi x) Kzero}. + Context {HFa: Feq Fa (Fopp Fone)} {HKa:Keq Ka (Kopp Kone)}. + Context {Hd:Keq (phi Fd) Kd} {Kdd Fdd} {HKdd:Keq Kdd (Kadd Kd Kd)} {HFdd:Feq Fdd (Fadd Fd Fd)}. + Local Notation Fpoint := (@point F Feq Fzero Fone Fadd Fmul Fdiv Fa Fd). + Local Notation Kpoint := (@point K Keq Kzero Kone Kadd Kmul Kdiv Ka Kd). + + Lemma Ha : Keq (phi Fa) Ka. + Proof. rewrite HFa, HKa, <-homomorphism_one. eapply homomorphism_opp. Qed. + + Lemma Hdd : Keq (phi Fdd) Kdd. + Proof. rewrite HFdd, HKdd. rewrite homomorphism_add. repeat f_equiv; auto. Qed. + + Create HintDb field_homomorphism discriminated. + Hint Rewrite <- + homomorphism_one + homomorphism_add + homomorphism_sub + homomorphism_mul + homomorphism_div + Ha + Hd + Hdd + : field_homomorphism. + + Program Definition ref_phi (P:Fpoint) : Kpoint := exist _ ( + let '(X, Y, Z, T) := coordinates P in (phi X, phi Y, phi Z, phi T)) _. + Next Obligation. + destruct P as [[[[] ?] ?] [? [? ?]]]; unfold onCurve in *; simpl. + rewrite_strat bottomup hints field_homomorphism. + eauto 10 using is_homomorphism_phi_proper, phi_nonzero. + Qed. + + Context {point_phi:Fpoint->Kpoint} + {point_phi_Proper:Proper (eq==>eq) point_phi} + {point_phi_correct: forall (P:Fpoint), eq (point_phi P) (ref_phi P)}. - End TwistMinus1. - - Definition negateExtended' P := let '(X, Y, Z, T) := P in (opp X, Y, Z, opp T). - Program Definition negateExtended (P:extendedPoint) : extendedPoint := negateExtended' (proj1_sig P). - Next Obligation. - Proof. - unfold negateExtended', rep; destruct P as [[X Y Z T] H]; simpl. destruct H as [[[] []] ?]; subst. - repeat rewrite ?F_div_opp_1, ?F_mul_opp_l, ?F_square_opp; repeat split; trivial. - Qed. - - Lemma negateExtended_correct : forall P, E.opp (unExtendedPoint P) = unExtendedPoint (negateExtended P). - Proof. - unfold E.opp, unExtendedPoint, negateExtended; destruct P as [[]]; simpl; intros. - eapply E.point_eq; repeat rewrite ?F_div_opp_1, ?F_mul_opp_l, ?F_square_opp; trivial. - Qed. -End ExtendedCoordinates. + Lemma lift_homomorphism : @Group.is_homomorphism Fpoint eq (add(a_eq_minus1:=HFa)(Htwice_d:=HFdd)) Kpoint eq (add(a_eq_minus1:=HKa)(Htwice_d:=HKdd)) point_phi. + Proof. + repeat match goal with + | |- Group.is_homomorphism => split + | |- _ => intro + | |- _ /\ _ => split + | [H: _ /\ _ |- _ ] => destruct H + | [p: point |- _ ] => destruct p as [[[[] ?] ?] [? [? ?]]] + | |- context[point_phi] => setoid_rewrite point_phi_correct + | |- _ => progress cbv [fst snd coordinates proj1_sig eq to_twisted E.eq E.coordinates fieldwise fieldwise' add add_coordinates ref_phi] in * + | |- Keq ?x ?x => reflexivity + | |- Keq ?x ?y => rewrite_strat bottomup hints field_homomorphism + | [ H : Feq _ _ |- Keq (phi _) (phi _)] => solve [f_equiv; intuition] + end. + Qed. + End Homomorphism. +End Extended. diff --git a/src/CompleteEdwardsCurve/Pre.v b/src/CompleteEdwardsCurve/Pre.v index fea4a99b3..5314ee37c 100644 --- a/src/CompleteEdwardsCurve/Pre.v +++ b/src/CompleteEdwardsCurve/Pre.v @@ -1,186 +1,100 @@ -Require Import Coq.ZArith.BinInt Coq.ZArith.Znumtheory Crypto.Tactics.VerdiTactics. +Require Import Coq.Classes.Morphisms. Require Coq.Setoids.Setoid. +Require Import Crypto.Algebra Crypto.Tactics.Nsatz. -Require Import Crypto.Spec.ModularArithmetic. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Local Open Scope F_scope. - +Generalizable All Variables. Section Pre. - Context {q : BinInt.Z}. - Context {a : F q}. - Context {d : F q}. - Context {prime_q : Znumtheory.prime q}. - Context {two_lt_q : 2 < q}. - Context {a_nonzero : a <> 0}. - Context {a_square : exists sqrt_a, sqrt_a^2 = a}. - Context {d_nonsquare : forall x, x^2 <> d}. - - Add Field Ffield_Z : (@Ffield_theory q _) - (morphism (@Fring_morph q), - preprocess [Fpreprocess], - postprocess [Fpostprocess], - constants [Fconstant], - div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). - + Context {F eq zero one opp add sub mul inv div} `{field F eq zero one opp add sub mul inv div}. + Local Infix "=" := eq. Local Notation "a <> b" := (not (a = b)). + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := zero. Local Notation "1" := one. + Local Infix "+" := add. Local Infix "*" := mul. + Local Infix "-" := sub. Local Infix "/" := div. + Local Notation "x '^' 2" := (x*x) (at level 30). + + Add Field EdwardsCurveField : (Field.field_theory_for_stdlib_tactic (T:=F)). + + Context {a:F} {a_nonzero : a<>0} {a_square : exists sqrt_a, sqrt_a^2 = a}. + Context {d:F} {d_nonsquare : forall sqrt_d, sqrt_d^2 <> d}. + Context {char_gt_2 : 1+1 <> 0}. + (* the canonical definitions are in Spec *) - Local Notation onCurve P := (let '(x, y) := P in a*x^2 + y^2 = 1 + d*x^2*y^2). - Local Notation unifiedAdd' P1' P2' := ( - let '(x1, y1) := P1' in - let '(x2, y2) := P2' in - (((x1*y2 + y1*x2)/(1 + d*x1*x2*y1*y2)) , ((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2))) - ). - - Lemma char_gt_2 : ZToField 2 <> (0: F q). - intro; find_injection. - pose proof two_lt_q. - rewrite (Z.mod_small 2 q), Z.mod_0_l in *; omega. - Qed. + Definition onCurve (P:F*F) := let (x, y) := P in a*x^2 + y^2 = 1 + d*x^2*y^2. + Definition unifiedAdd' (P1' P2':F*F) : F*F := + let (x1, y1) := P1' in + let (x2, y2) := P2' in + pair (((x1*y2 + y1*x2)/(1 + d*x1*x2*y1*y2))) (((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2))). - Ltac rewriteAny := match goal with [H: _ = _ |- _ ] => rewrite H end. - Ltac rewriteLeftAny := match goal with [H: _ = _ |- _ ] => rewrite <- H end. - - Ltac whatsNotZero := - repeat match goal with - | [H: ?lhs = ?rhs |- _ ] => - match goal with [Ha: lhs <> 0 |- _ ] => fail 1 | _ => idtac end; - assert (lhs <> 0) by (rewrite H; auto using Fq_1_neq_0) - | [H: ?lhs = ?rhs |- _ ] => - match goal with [Ha: rhs <> 0 |- _ ] => fail 1 | _ => idtac end; - assert (rhs <> 0) by (rewrite H; auto using Fq_1_neq_0) - | [H: (?a^?p)%F <> 0 |- _ ] => - match goal with [Ha: a <> 0 |- _ ] => fail 1 | _ => idtac end; - let Y:=fresh in let Z:=fresh in try ( - assert (p <> 0%N) as Z by (intro Y; inversion Y); - assert (a <> 0) by (eapply Fq_root_nonzero; eauto using Fq_1_neq_0); - clear Z) - | [H: (?a*?b)%F <> 0 |- _ ] => - match goal with [Ha: a <> 0 |- _ ] => fail 1 | _ => idtac end; - assert (a <> 0) by (eapply F_mul_nonzero_l; eauto using Fq_1_neq_0) - | [H: (?a*?b)%F <> 0 |- _ ] => - match goal with [Ha: b <> 0 |- _ ] => fail 1 | _ => idtac end; - assert (b <> 0) by (eapply F_mul_nonzero_r; eauto using Fq_1_neq_0) - end. + Ltac use_sqrt_a := destruct a_square as [sqrt_a a_square']; rewrite <-a_square' in *. Lemma edwardsAddComplete' x1 y1 x2 y2 : - onCurve (x1, y1) -> - onCurve (x2, y2) -> + onCurve (pair x1 y1) -> + onCurve (pair x2 y2) -> (d*x1*x2*y1*y2)^2 <> 1. Proof. - intros Hc1 Hc2 Hcontra; simpl in Hc1, Hc2; whatsNotZero. - - pose proof char_gt_2. pose proof a_nonzero as Ha_nonzero. - destruct a_square as [sqrt_a a_square']. - rewrite <-a_square' in *. - - (* Furthermore... *) - pose proof (eq_refl (d*x1^2*y1^2*(sqrt_a^2*x2^2 + y2^2))) as Heqt. - rewrite Hc2 in Heqt at 2. - replace (d * x1 ^ 2 * y1 ^ 2 * (1 + d * x2 ^ 2 * y2 ^ 2)) - with (d*x1^2*y1^2 + (d*x1*x2*y1*y2)^2) in Heqt by field. - rewrite Hcontra in Heqt. - replace (d * x1 ^ 2 * y1 ^ 2 + 1) with (1 + d * x1 ^ 2 * y1 ^ 2) in Heqt by field. - rewrite <-Hc1 in Heqt. - - (* main equation for both potentially nonzero denominators *) - destruct (F_eq_dec (sqrt_a*x2 + y2) 0); destruct (F_eq_dec (sqrt_a*x2 - y2) 0); - try lazymatch goal with [H: ?f (sqrt_a * x2) y2 <> 0 |- _ ] => - assert ((f (sqrt_a*x1) (d * x1 * x2 * y1 * y2*y1))^2 = - f ((sqrt_a^2)*x1^2 + (d * x1 * x2 * y1 * y2)^2*y1^2) - (d * x1 * x2 * y1 * y2*sqrt_a*(ZToField 2)*x1*y1)) as Heqw1 by field; - rewrite Hcontra in Heqw1; - replace (1 * y1^2) with (y1^2) in * by field; - rewrite <- Heqt in *; - assert (d = (f (sqrt_a * x1) (d * x1 * x2 * y1 * y2 * y1))^2 / - (x1 * y1 * (f (sqrt_a * x2) y2))^2) - by (rewriteAny; field; auto); - match goal with [H: d = (?n^2)/(?l^2) |- _ ] => - destruct (d_nonsquare (n/l)); (remember n; rewriteAny; field; auto) - end - end. - - assert (Hc: (sqrt_a * x2 + y2) + (sqrt_a * x2 - y2) = 0) by (repeat rewriteAny; field). - - replace (sqrt_a * x2 + y2 + (sqrt_a * x2 - y2)) with (ZToField 2 * sqrt_a * x2) in Hc by field. - - (* contradiction: product of nonzero things is zero *) - destruct (Fq_mul_zero_why _ _ Hc) as [Hcc|Hcc]; subst; intuition. - destruct (Fq_mul_zero_why _ _ Hcc) as [Hccc|Hccc]; subst; intuition. - apply Ha_nonzero; field. + unfold onCurve, not; use_sqrt_a; intros. + destruct (eq_dec (sqrt_a*x2 + y2) 0); destruct (eq_dec (sqrt_a*x2 - y2) 0); + lazymatch goal with + | [H: not (eq (?f (sqrt_a * x2) y2) 0) |- _ ] + => apply d_nonsquare with (sqrt_d:= (f (sqrt_a * x1) (d * x1 * x2 * y1 * y2 * y1)) + /(f (sqrt_a * x2) y2 * x1 * y1 )) + | _ => apply a_nonzero + end; field_algebra; auto using Ring.opp_nonzero_nonzero; intro; nsatz_contradict. Qed. Lemma edwardsAddCompletePlus x1 y1 x2 y2 : - onCurve (x1, y1) -> - onCurve (x2, y2) -> - (1 + d*x1*x2*y1*y2) <> 0. - Proof. - intros Hc1 Hc2; simpl in Hc1, Hc2. - intros; destruct (F_eq_dec (d*x1*x2*y1*y2) (0-1)) as [H|H]. - - assert ((d*x1*x2*y1*y2)^2 = 1) by (rewriteAny; field). destruct (edwardsAddComplete' x1 y1 x2 y2); auto. - - replace (d * x1 * x2 * y1 * y2) with (1+d * x1 * x2 * y1 * y2-1) in H by field. - intro Hz; rewrite Hz in H; intuition. - Qed. - + onCurve (x1, y1) -> onCurve (x2, y2) -> (1 + d*x1*x2*y1*y2) <> 0. + Proof. intros H1 H2 ?. apply (edwardsAddComplete' _ _ _ _ H1 H2); field_algebra. Qed. + Lemma edwardsAddCompleteMinus x1 y1 x2 y2 : - onCurve (x1, y1) -> - onCurve (x2, y2) -> - (1 - d*x1*x2*y1*y2) <> 0. - Proof. - intros Hc1 Hc2. destruct (F_eq_dec (d*x1*x2*y1*y2) 1) as [H|H]. - - assert ((d*x1*x2*y1*y2)^2 = 1) by (rewriteAny; field). destruct (edwardsAddComplete' x1 y1 x2 y2); auto. - - replace (d * x1 * x2 * y1 * y2) with ((1-(1-d * x1 * x2 * y1 * y2))) in H by field. - intro Hz; rewrite Hz in H; apply H; field. - Qed. - - Definition zeroOnCurve : onCurve (0, 1). - simpl. field. - Qed. - - Lemma unifiedAdd'_onCurve' x1 y1 x2 y2 x3 y3 - (H: (x3, y3) = unifiedAdd' (x1, y1) (x2, y2)) : - onCurve (x1, y1) -> onCurve (x2, y2) -> onCurve (x3, y3). + onCurve (x1, y1) -> onCurve (x2, y2) -> (1 - d*x1*x2*y1*y2) <> 0. + Proof. intros H1 H2 ?. apply (edwardsAddComplete' _ _ _ _ H1 H2); field_algebra. Qed. + + Lemma zeroOnCurve : onCurve (0, 1). Proof. simpl. field_algebra. Qed. + + Lemma unifiedAdd'_onCurve : forall P1 P2, + onCurve P1 -> onCurve P2 -> onCurve (unifiedAdd' P1 P2). Proof. - (* https://eprint.iacr.org/2007/286.pdf Theorem 3.1; - * c=1 and an extra a in front of x^2 *) - - injection H; clear H; intros. - - Ltac t x1 y1 x2 y2 := - assert ((a*x2^2 + y2^2)*d*x1^2*y1^2 - = (1 + d*x2^2*y2^2) * d*x1^2*y1^2) by (rewriteAny; auto); - assert (a*x1^2 + y1^2 - (a*x2^2 + y2^2)*d*x1^2*y1^2 - = 1 - d^2*x1^2*x2^2*y1^2*y2^2) by (repeat rewriteAny; field). - t x1 y1 x2 y2; t x2 y2 x1 y1. - - remember ((a*x1^2 + y1^2 - (a*x2^2+y2^2)*d*x1^2*y1^2)*(a*x2^2 + y2^2 - - (a*x1^2 + y1^2)*d*x2^2*y2^2)) as T. - assert (HT1: T = (1 - d^2*x1^2*x2^2*y1^2*y2^2)^2) by (repeat rewriteAny; field). - assert (HT2: T = (a * ((x1 * y2 + y1 * x2) * (1 - d * x1 * x2 * y1 * y2)) ^ 2 +( - (y1 * y2 - a * x1 * x2) * (1 + d * x1 * x2 * y1 * y2)) ^ 2 -d * ((x1 * - y2 + y1 * x2)* (y1 * y2 - a * x1 * x2))^2)) by (subst; field). - replace (1:F q) with (a*x3^2 + y3^2 -d*x3^2*y3^2); [field|]; subst x3 y3. - - match goal with [ |- ?x = 1 ] => replace x with - ((a * ((x1 * y2 + y1 * x2) * (1 - d * x1 * x2 * y1 * y2)) ^ 2 + - ((y1 * y2 - a * x1 * x2) * (1 + d * x1 * x2 * y1 * y2)) ^ 2 - - d*((x1 * y2 + y1 * x2) * (y1 * y2 - a * x1 * x2)) ^ 2)/ - ((1-d^2*x1^2*x2^2*y1^2*y2^2)^2)) end. - - rewrite <-HT1, <-HT2; field; rewrite HT1. - replace ((1 - d ^ 2 * x1 ^ 2 * x2 ^ 2 * y1 ^ 2 * y2 ^ 2)) - with ((1 - d*x1*x2*y1*y2)*(1 + d*x1*x2*y1*y2)) by field. - auto using Fq_pow_nonzero, Fq_mul_nonzero_nonzero, - edwardsAddCompleteMinus, edwardsAddCompletePlus. - - field; replace (1 - (d * x1 * x2 * y1 * y2) ^ 2) - with ((1 - d*x1*x2*y1*y2)*(1 + d*x1*x2*y1*y2)) - by field; - auto using Fq_pow_nonzero, Fq_mul_nonzero_nonzero, - edwardsAddCompleteMinus, edwardsAddCompletePlus. + unfold onCurve, unifiedAdd'; intros [x1 y1] [x2 y2] H1 H2. + field_algebra; auto using edwardsAddCompleteMinus, edwardsAddCompletePlus. Qed. - - Lemma unifiedAdd'_onCurve : forall P1 P2, onCurve P1 -> onCurve P2 -> - onCurve (unifiedAdd' P1 P2). +End Pre. + +Import Group Ring Field. + +(* TODO: move -- this does not need to be defined before [point] *) +Section RespectsFieldHomomorphism. + Context {F EQ ZERO ONE OPP ADD MUL SUB INV DIV} `{@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}. + Context {K eq zero one opp add mul sub inv div} `{@field K eq zero one opp add sub mul inv div}. + Local Infix "=" := eq. Local Infix "=" := eq : type_scope. + Context {phi:F->K} `{@is_homomorphism F EQ ONE ADD MUL K eq one add mul phi}. + Context {A D:F} {a d:K} {a_ok:phi A=a} {d_ok:phi D=d}. + + Let phip := fun (P':F*F) => let (x, y) := P' in (phi x, phi y). + + Let eqp := fun (P1' P2':K*K) => + let (x1, y1) := P1' in + let (x2, y2) := P2' in + and (eq x1 x2) (eq y1 y2). + + Create HintDb field_homomorphism discriminated. + Hint Rewrite + homomorphism_one + homomorphism_add + homomorphism_sub + homomorphism_mul + homomorphism_div + a_ok + d_ok + : field_homomorphism. + + Lemma morphism_unidiedAdd' : forall P Q:F*F, + eqp + (phip (unifiedAdd'(F:=F)(one:=ONE)(add:=ADD)(sub:=SUB)(mul:=MUL)(div:=DIV)(a:=A)(d:=D) P Q)) + (unifiedAdd'(F:=K)(one:=one)(add:=add)(sub:=sub)(mul:=mul)(div:=div)(a:=a)(d:=d) (phip P) (phip Q)). Proof. - intros; destruct P1, P2. - remember (unifiedAdd' (f, f0) (f1, f2)) as r; destruct r. - eapply unifiedAdd'_onCurve'; eauto. + intros [x1 y1] [x2 y2]. + cbv [unifiedAdd' phip eqp]; + apply conj; + (rewrite_strat topdown hints field_homomorphism); reflexivity. Qed. -End Pre.
\ No newline at end of file +End RespectsFieldHomomorphism.
\ No newline at end of file diff --git a/src/EdDSAProofs.v b/src/EdDSAProofs.v deleted file mode 100644 index dba71b49c..000000000 --- a/src/EdDSAProofs.v +++ /dev/null @@ -1,78 +0,0 @@ -Require Import Crypto.Spec.EdDSA Crypto.Spec.Encoding. -Require Import Coq.Numbers.Natural.Peano.NPeano. -Require Import Bedrock.Word. -Require Import Coq.ZArith.Znumtheory Coq.ZArith.BinInt Coq.ZArith.ZArith. -Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems Crypto.ModularArithmetic.ModularArithmeticTheorems. -Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil. -Require Import Crypto.Tactics.VerdiTactics. -Local Open Scope nat_scope. - -Section EdDSAProofs. - Context {prm:EdDSAParams}. - Existing Instance E. - Existing Instance PointEncoding. - Existing Instance FqEncoding. - Existing Instance FlEncoding. - Existing Instance n_le_b. - Hint Rewrite sign_spec split1_combine split2_combine. - Hint Rewrite Nat.mod_mod using omega. - - Ltac arith' := intros; autorewrite with core; try (omega || congruence). - - Ltac arith := arith'; - repeat match goal with - | [ H : _ |- _ ] => rewrite H; arith' - end. - - (* for signature (R_, S_), R_ = encode_point (r * B) *) - Lemma decode_sign_split1 : forall A_ sk {n} (M : word n), - split1 b b (sign A_ sk M) = enc (wordToNat (H (prngKey sk ++ M)) * B)%E. - Proof. - unfold sign; arith. - Qed. - Hint Rewrite decode_sign_split1. - - (* for signature (R_, S_), S_ = encode_scalar (r + H(R_, A_, M)s) *) - Lemma decode_sign_split2 : forall sk {n} (M : word n), - split2 b b (sign (public sk) sk M) = - let r : nat := H (prngKey sk ++ M) in (* secret nonce *) - let R : E.point := (r * B)%E in (* commitment to nonce *) - let s : nat := curveKey sk in (* secret scalar *) - let S : F (Z.of_nat l) := ZToField (Z.of_nat (r + H (enc R ++ public sk ++ M) * s)) in - enc S. - Proof. - unfold sign; arith. - Qed. - Hint Rewrite decode_sign_split2. - - Hint Rewrite E.add_0_r E.add_0_l E.add_assoc. - Hint Rewrite E.mul_assoc E.mul_add_l E.mul_0_l E.mul_zero_r. - Hint Rewrite plus_O_n plus_Sn_m mult_0_l mult_succ_l. - Hint Rewrite l_order_B. - Lemma l_order_B' : forall x, (l * x * B = E.zero)%E. - Proof. - intros; rewrite Mult.mult_comm. rewrite <- E.mul_assoc. arith. - Qed. Hint Rewrite l_order_B'. - - Lemma scalarMult_mod_l : forall n0, (n0 mod l * B = n0 * B)%E. - Proof. - intros. - rewrite (div_mod n0 l) at 2 by (generalize l_odd; omega). - arith. - Qed. Hint Rewrite scalarMult_mod_l. - - Hint Rewrite @encoding_valid. - Hint Rewrite @FieldToZ_ZToField. - Hint Rewrite <-mod_Zmod. - Hint Rewrite Nat2Z.id. - - Lemma l_nonzero : l <> O. pose l_odd; omega. Qed. - Hint Resolve l_nonzero. - - Lemma verify_valid_passes : forall sk {n} (M : word n), - verify (public sk) M (sign (public sk) sk M) = true. - Proof. - unfold verify, sign, public; arith; try break_if; intuition. - Qed. -End EdDSAProofs. diff --git a/src/Encoding/EncodingTheorems.v b/src/Encoding/EncodingTheorems.v index 52ac91ada..c6f48a0ab 100644 --- a/src/Encoding/EncodingTheorems.v +++ b/src/Encoding/EncodingTheorems.v @@ -2,7 +2,7 @@ Require Import Crypto.Spec.Encoding. Section EncodingTheorems. Context {A B : Type} {E : canonical encoding of A as B}. - + Lemma encoding_inj : forall x y, enc x = enc y -> x = y. Proof. intros. diff --git a/src/Encoding/ModularWordEncodingTheorems.v b/src/Encoding/ModularWordEncodingTheorems.v index 7251ac1e6..41b75e216 100644 --- a/src/Encoding/ModularWordEncodingTheorems.v +++ b/src/Encoding/ModularWordEncodingTheorems.v @@ -24,7 +24,7 @@ Section SignBit. assert (m < 1)%Z by (apply Z2Nat.inj_lt; try omega; assumption). omega. + assert (0 < m)%Z as m_pos by (pose proof prime_ge_2 m prime_m; omega). - pose proof (FieldToZ_range x m_pos). + pose proof (FieldToZ_range x m_pos). destruct (FieldToZ x); auto. - destruct p; auto. - pose proof (Pos2Z.neg_is_neg p); omega. diff --git a/src/Encoding/PointEncodingPre.v b/src/Encoding/PointEncodingPre.v deleted file mode 100644 index 73ced869b..000000000 --- a/src/Encoding/PointEncodingPre.v +++ /dev/null @@ -1,275 +0,0 @@ -Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. -Require Import Coq.Numbers.Natural.Peano.NPeano. -Require Import Coq.Program.Equality. -Require Import Crypto.Encoding.EncodingTheorems. -Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Require Import Bedrock.Word. -Require Import Crypto.Encoding.ModularWordEncodingTheorems. -Require Import Crypto.Tactics.VerdiTactics. -Require Import Crypto.Util.ZUtil. - -Require Import Crypto.Spec.Encoding Crypto.Spec.ModularWordEncoding Crypto.Spec.ModularArithmetic. - -Local Open Scope F_scope. - -Section PointEncoding. - Context {prm: TwistedEdwardsParams} {sz : nat} {sz_nonzero : (0 < sz)%nat} - {bound_check : (Z.to_nat q < 2 ^ sz)%nat} {q_5mod8 : (q mod 8 = 5)%Z} - {sqrt_minus1_valid : (@ZToField q 2 ^ Z.to_N (q / 4)) ^ 2 = opp 1} - {FqEncoding : canonical encoding of (F q) as (word sz)} - {sign_bit : F q -> bool} {sign_bit_zero : sign_bit 0 = false} - {sign_bit_opp : forall x, x <> 0 -> negb (sign_bit x) = sign_bit (opp x)}. - Existing Instance prime_q. - - Add Field Ffield : (@Ffield_theory q _) - (morphism (@Fring_morph q), - preprocess [Fpreprocess], - postprocess [Fpostprocess; try exact Fq_1_neq_0; try assumption], - constants [Fconstant], - div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). - - Definition sqrt_valid (a : F q) := ((sqrt_mod_q a) ^ 2 = a)%F. - - Lemma solve_sqrt_valid : forall p, E.onCurve p -> - sqrt_valid (E.solve_for_x2 (snd p)). - Proof. - intros ? onCurve_xy. - destruct p as [x y]; simpl. - rewrite (E.solve_correct x y) in onCurve_xy. - rewrite <- onCurve_xy. - unfold sqrt_valid. - eapply sqrt_mod_q_valid; eauto. - unfold isSquare; eauto. - Grab Existential Variables. eauto. - Qed. - - Lemma solve_onCurve: forall (y : F q), sqrt_valid (E.solve_for_x2 y) -> - E.onCurve (sqrt_mod_q (E.solve_for_x2 y), y). - Proof. - intros. - unfold sqrt_valid in *. - apply E.solve_correct; auto. - Qed. - - Lemma solve_opp_onCurve: forall (y : F q), sqrt_valid (E.solve_for_x2 y) -> - E.onCurve (opp (sqrt_mod_q (E.solve_for_x2 y)), y). - Proof. - intros y sqrt_valid_x2. - unfold sqrt_valid in *. - apply E.solve_correct. - rewrite <- sqrt_valid_x2 at 2. - ring. - Qed. - - Definition point_enc_coordinates (p : (F q * F q)) : Word.word (S sz) := let '(x,y) := p in - Word.WS (sign_bit x) (enc y). - - Let point_enc (p : E.point) : Word.word (S sz) := let '(x,y) := proj1_sig p in - Word.WS (sign_bit x) (enc y). - - Definition point_dec_coordinates (sign_bit : F q -> bool) (w : Word.word (S sz)) : option (F q * F q) := - match dec (Word.wtl w) with - | None => None - | Some y => let x2 := E.solve_for_x2 y in - let x := sqrt_mod_q x2 in - if F_eq_dec (x ^ 2) x2 - then - let p := (if Bool.eqb (whd w) (sign_bit x) then x else opp x, y) in - if (andb (F_eqb x 0) (whd w)) - then None (* special case for 0, since its opposite has the same sign; if the sign bit of 0 is 1, produce None.*) - else Some p - else None - end. - - Ltac inversion_Some_eq := match goal with [H: Some ?x = Some ?y |- _] => inversion H; subst end. - - Lemma point_dec_coordinates_onCurve : forall w p, point_dec_coordinates sign_bit w = Some p -> E.onCurve p. - Proof. - unfold point_dec_coordinates; intros. - edestruct dec; [ | congruence]. - break_if; [ | congruence]. - break_if; [ congruence | ]. - break_if; inversion_Some_eq; auto using solve_onCurve, solve_opp_onCurve. - Qed. - - Lemma prod_eq_dec : forall {A} (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'}) - (x y : (A * A)), {x = y} + {x <> y}. - Proof. - decide equality. - Qed. - - Lemma option_eq_dec : forall {A} (A_eq_dec : forall a a' : A, {a = a'} + {a <> a'}) - (x y : option A), {x = y} + {x <> y}. - Proof. - decide equality. - Qed. - - Definition point_dec' w p : option E.point := - match (option_eq_dec (prod_eq_dec F_eq_dec) (point_dec_coordinates sign_bit w) (Some p)) with - | left EQ => Some (exist _ p (point_dec_coordinates_onCurve w p EQ)) - | right _ => None (* this case is never reached *) - end. - - Definition point_dec (w : word (S sz)) : option E.point := - match (point_dec_coordinates sign_bit w) with - | Some p => point_dec' w p - | None => None - end. - - Lemma point_coordinates_encoding_canonical : forall w p, - point_dec_coordinates sign_bit w = Some p -> point_enc_coordinates p = w. - Proof. - unfold point_dec_coordinates, point_enc_coordinates; intros ? ? coord_dec_Some. - case_eq (dec (wtl w)); [ intros ? dec_Some | intros dec_None; rewrite dec_None in *; congruence ]. - destruct p. - rewrite (shatter_word w). - f_equal; rewrite dec_Some in *; - do 2 (break_if; try congruence); inversion coord_dec_Some; subst. - + destruct (F_eq_dec (sqrt_mod_q (E.solve_for_x2 f1)) 0%F) as [sqrt_0 | ?]. - - rewrite sqrt_0 in *. - apply sqrt_mod_q_root_0 in sqrt_0; try assumption. - rewrite sqrt_0 in *. - break_if; [symmetry; auto using Bool.eqb_prop | ]. - rewrite sign_bit_zero in *. - simpl in Heqb; rewrite Heqb in *. - discriminate. - - break_if. - symmetry; auto using Bool.eqb_prop. - rewrite <- sign_bit_opp by assumption. - destruct (whd w); inversion Heqb0; break_if; auto. - + inversion coord_dec_Some; subst. - auto using encoding_canonical. -Qed. - - Lemma point_encoding_canonical : forall w x, point_dec w = Some x -> point_enc x = w. - Proof. - (* - unfold point_enc; intros. - unfold point_dec in *. - assert (point_dec_coordinates w = Some (proj1_sig x)). { - set (y := point_dec_coordinates w) in *. - revert H. - dependent destruction y. intros. - rewrite H0 in H. - *) - Admitted. - -Lemma point_dec_coordinates_correct w - : option_map (@proj1_sig _ _) (point_dec w) = point_dec_coordinates sign_bit w. -Proof. - unfold point_dec, option_map. - do 2 break_match; try congruence; unfold point_dec' in *; - break_match; try congruence. - inversion_Some_eq. - reflexivity. -Qed. - -Lemma y_decode : forall p, dec (wtl (point_enc_coordinates p)) = Some (snd p). -Proof. - intros. - destruct p as [x y]; simpl. - exact (encoding_valid y). -Qed. - -Lemma sign_bit_opp_eq_iff : forall x y, y <> 0 -> - (sign_bit x <> sign_bit y <-> sign_bit x = sign_bit (opp y)). -Proof. - split; intro sign_mismatch; case_eq (sign_bit x); case_eq (sign_bit y); - try congruence; intros y_sign x_sign; rewrite <- sign_bit_opp in * by auto; - rewrite y_sign, x_sign in *; reflexivity || discriminate. -Qed. - -Lemma sign_bit_squares : forall x y, y <> 0 -> x ^ 2 = y ^ 2 -> - sign_bit x = sign_bit y -> x = y. -Proof. - intros ? ? y_nonzero squares_eq sign_match. - destruct (sqrt_solutions _ _ squares_eq) as [? | eq_opp]; auto. - assert (sign_bit x = sign_bit (opp y)) as sign_mismatch by (f_equal; auto). - apply sign_bit_opp_eq_iff in sign_mismatch; auto. - congruence. -Qed. - -Lemma sign_bit_match : forall x x' y : F q, E.onCurve (x, y) -> E.onCurve (x', y) -> - sign_bit x = sign_bit x' -> x = x'. -Proof. - intros ? ? ? onCurve_x onCurve_x' sign_match. - apply E.solve_correct in onCurve_x. - apply E.solve_correct in onCurve_x'. - destruct (F_eq_dec x' 0). - + subst. - rewrite Fq_pow_zero in onCurve_x' by congruence. - rewrite <- onCurve_x' in *. - eapply Fq_root_zero; eauto. - + apply sign_bit_squares; auto. - rewrite onCurve_x, onCurve_x'. - reflexivity. -Qed. - -Lemma point_encoding_coordinates_valid : forall p, E.onCurve p -> - point_dec_coordinates sign_bit (point_enc_coordinates p) = Some p. -Proof. - intros p onCurve_p. - unfold point_dec_coordinates. - rewrite y_decode. - pose proof (solve_sqrt_valid p onCurve_p) as solve_sqrt_valid_p. - destruct p as [x y]. - unfold sqrt_valid in *. - simpl. - replace (E.solve_for_x2 y) with (x ^ 2 : F q) in * by (apply E.solve_correct; assumption). - case_eq (F_eqb x 0); intro eqb_x_0. - + apply F_eqb_eq in eqb_x_0; rewrite eqb_x_0 in *. - rewrite !Fq_pow_zero, sqrt_mod_q_of_0, Fq_pow_zero by congruence. - rewrite if_F_eq_dec_if_F_eqb, sign_bit_zero. - reflexivity. - + assert (sqrt_mod_q (x ^ 2) <> 0) by (intro false_eq; apply sqrt_mod_q_root_0 in false_eq; try assumption; - apply Fq_root_zero in false_eq; rewrite false_eq, F_eqb_refl in eqb_x_0; congruence). - replace (F_eqb (sqrt_mod_q (x ^ 2)) 0) with false by (symmetry; - apply F_eqb_neq_complete; assumption). - break_if. - - simpl. - f_equal. - break_if. - * rewrite Bool.eqb_true_iff in Heqb. - pose proof (solve_onCurve y solve_sqrt_valid_p). - f_equal. - apply (sign_bit_match _ _ y); auto. - apply E.solve_correct in onCurve_p; rewrite onCurve_p in *. - assumption. - * rewrite Bool.eqb_false_iff in Heqb. - pose proof (solve_opp_onCurve y solve_sqrt_valid_p). - f_equal. - apply sign_bit_opp_eq_iff in Heqb; try assumption. - apply (sign_bit_match _ _ y); auto. - apply E.solve_correct in onCurve_p. - rewrite onCurve_p; auto. - - simpl in solve_sqrt_valid_p. - replace (E.solve_for_x2 y) with (x ^ 2 : F q) in * by (apply E.solve_correct; assumption). - congruence. -Qed. - -Lemma point_dec'_valid : forall p, - point_dec' (point_enc_coordinates (proj1_sig p)) (proj1_sig p) = Some p. -Proof. - unfold point_dec'; intros. - break_match. - + f_equal. - destruct p. - apply E.point_eq. - reflexivity. - + rewrite point_encoding_coordinates_valid in n by apply (proj2_sig p). - congruence. -Qed. - -Lemma point_encoding_valid : forall p, point_dec (point_enc p) = Some p. -Proof. - intros. - unfold point_dec. - replace (point_enc p) with (point_enc_coordinates (proj1_sig p)) by reflexivity. - break_match; rewrite point_encoding_coordinates_valid in * by apply (proj2_sig p); try congruence. - inversion_Some_eq. - eapply point_dec'_valid. -Qed. - -End PointEncoding. diff --git a/src/Encoding/PointEncodingTheorems.v b/src/Encoding/PointEncodingTheorems.v deleted file mode 100644 index ccea1d81b..000000000 --- a/src/Encoding/PointEncodingTheorems.v +++ /dev/null @@ -1,207 +0,0 @@ -Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. -Require Import Coq.Numbers.Natural.Peano.NPeano. -Require Import Coq.Program.Equality. -Require Import Crypto.Encoding.EncodingTheorems. -Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Require Import Bedrock.Word. -Require Import Crypto.Tactics.VerdiTactics. - -Require Import Crypto.Spec.Encoding Crypto.Spec.ModularArithmetic Crypto.Spec.CompleteEdwardsCurve. - -Local Open Scope F_scope. - -Section PointEncoding. - Context {prm: CompleteEdwardsCurve.TwistedEdwardsParams} {sz : nat} - {FqEncoding : canonical encoding of ModularArithmetic.F (CompleteEdwardsCurve.q) as Word.word sz} - {q_5mod8 : (CompleteEdwardsCurve.q mod 8 = 5)%Z} - {sqrt_minus1_valid : (@ZToField CompleteEdwardsCurve.q 2 ^ BinInt.Z.to_N (CompleteEdwardsCurve.q / 4)) ^ 2 = opp 1}. - Existing Instance CompleteEdwardsCurve.prime_q. - - Add Field Ffield : (@PrimeFieldTheorems.Ffield_theory CompleteEdwardsCurve.q _) - (morphism (@ModularArithmeticTheorems.Fring_morph CompleteEdwardsCurve.q), - preprocess [ModularArithmeticTheorems.Fpreprocess], - postprocess [ModularArithmeticTheorems.Fpostprocess; try exact PrimeFieldTheorems.Fq_1_neq_0; try assumption], - constants [ModularArithmeticTheorems.Fconstant], - div (@ModularArithmeticTheorems.Fmorph_div_theory CompleteEdwardsCurve.q), - power_tac (@ModularArithmeticTheorems.Fpower_theory CompleteEdwardsCurve.q) [ModularArithmeticTheorems.Fexp_tac]). - - Definition sqrt_valid (a : F q) := ((sqrt_mod_q a) ^ 2 = a)%F. - - Lemma solve_sqrt_valid : forall (p : E.point), - sqrt_valid (E.solve_for_x2 (snd (proj1_sig p))). - Proof. - intros. - destruct p as [[x y] onCurve_xy]; simpl. - rewrite (E.solve_correct x y) in onCurve_xy. - rewrite <- onCurve_xy. - unfold sqrt_valid. - eapply sqrt_mod_q_valid; eauto. - unfold isSquare; eauto. - Grab Existential Variables. eauto. - Qed. - - Lemma solve_onCurve: forall (y : F q), sqrt_valid (E.solve_for_x2 y) -> - E.onCurve (sqrt_mod_q (E.solve_for_x2 y), y). - Proof. - intros. - unfold sqrt_valid in *. - apply E.solve_correct; auto. - Qed. - - Lemma solve_opp_onCurve: forall (y : F q), sqrt_valid (E.solve_for_x2 y) -> - E.onCurve (opp (sqrt_mod_q (E.solve_for_x2 y)), y). - Proof. - intros y sqrt_valid_x2. - unfold sqrt_valid in *. - apply E.solve_correct. - rewrite <- sqrt_valid_x2 at 2. - ring. - Qed. - -Definition sign_bit (x : F q) := (wordToN (enc (opp x)) <? wordToN (enc x))%N. -Definition point_enc (p : E.point) : word (S sz) := let '(x,y) := proj1_sig p in - WS (sign_bit x) (enc y). -Definition point_dec_coordinates (w : word (S sz)) : option (F q * F q) := - match dec (wtl w) with - | None => None - | Some y => let x2 := E.solve_for_x2 y in - let x := sqrt_mod_q x2 in - if F_eq_dec (x ^ 2) x2 - then - let p := (if Bool.eqb (whd w) (sign_bit x) then x else opp x, y) in - Some p - else None - end. - -Definition point_dec (w : word (S sz)) : option E.point := - match dec (wtl w) with - | None => None - | Some y => let x2 := E.solve_for_x2 y in - let x := sqrt_mod_q x2 in - match (F_eq_dec (x ^ 2) x2) with - | right _ => None - | left EQ => if Bool.eqb (whd w) (sign_bit x) - then Some (exist _ (x, y) (solve_onCurve y EQ)) - else Some (exist _ (opp x, y) (solve_opp_onCurve y EQ)) - end - end. - -Lemma point_dec_coordinates_correct w - : option_map (@proj1_sig _ _) (point_dec w) = point_dec_coordinates w. -Proof. - unfold point_dec, point_dec_coordinates. - edestruct dec; [ | reflexivity ]. - edestruct @F_eq_dec; [ | reflexivity ]. - edestruct @Bool.eqb; reflexivity. -Qed. - -Lemma y_decode : forall p, dec (wtl (point_enc p)) = Some (snd (proj1_sig p)). -Proof. - intros. - destruct p as [[x y] onCurve_p]; simpl. - exact (encoding_valid y). -Qed. - - -Lemma wordToN_enc_neq_opp : forall x, x <> 0 -> (wordToN (enc (opp x)) <> wordToN (enc x))%N. -Proof. - intros x x_nonzero. - intro false_eq. - apply x_nonzero. - apply F_eq_opp_zero; try apply two_lt_q. - apply wordToN_inj in false_eq. - apply encoding_inj in false_eq. - auto. -Qed. - -Lemma sign_bit_opp_negb : forall x, x <> 0 -> negb (sign_bit x) = sign_bit (opp x). -Proof. - intros x x_nonzero. - unfold sign_bit. - rewrite <- N.leb_antisym. - rewrite N.ltb_compare, N.leb_compare. - rewrite F_opp_involutive. - case_eq (wordToN (enc x) ?= wordToN (enc (opp x)))%N; auto. - intro wordToN_enc_eq. - pose proof (wordToN_enc_neq_opp x x_nonzero). - apply N.compare_eq_iff in wordToN_enc_eq. - congruence. -Qed. - -Lemma sign_bit_opp : forall x y, y <> 0 -> - (sign_bit x <> sign_bit y <-> sign_bit x = sign_bit (opp y)). -Proof. - split; intro sign_mismatch; case_eq (sign_bit x); case_eq (sign_bit y); - try congruence; intros y_sign x_sign; rewrite <- sign_bit_opp_negb in * by auto; - rewrite y_sign, x_sign in *; reflexivity || discriminate. -Qed. - -Lemma sign_bit_squares : forall x y, y <> 0 -> x ^ 2 = y ^ 2 -> - sign_bit x = sign_bit y -> x = y. -Proof. - intros ? ? y_nonzero squares_eq sign_match. - destruct (sqrt_solutions _ _ squares_eq) as [? | eq_opp]; auto. - assert (sign_bit x = sign_bit (opp y)) as sign_mismatch by (f_equal; auto). - apply sign_bit_opp in sign_mismatch; auto. - congruence. -Qed. - -Lemma sign_bit_match : forall x x' y : F q, E.onCurve (x, y) -> E.onCurve (x', y) -> - sign_bit x = sign_bit x' -> x = x'. -Proof. - intros ? ? ? onCurve_x onCurve_x' sign_match. - apply E.solve_correct in onCurve_x. - apply E.solve_correct in onCurve_x'. - destruct (F_eq_dec x' 0). - + subst. - rewrite Fq_pow_zero in onCurve_x' by congruence. - rewrite <- onCurve_x' in *. - eapply Fq_root_zero; eauto. - + apply sign_bit_squares; auto. - rewrite onCurve_x, onCurve_x'. - reflexivity. -Qed. - -Lemma point_encoding_valid : forall p, point_dec (point_enc p) = Some p. -Proof. - intros. - unfold point_dec. - rewrite y_decode. - pose proof solve_sqrt_valid p as solve_sqrt_valid_p. - unfold sqrt_valid in *. - destruct p as [[x y] onCurve_p]. - simpl in *. - destruct (F_eq_dec ((sqrt_mod_q (E.solve_for_x2 y)) ^ 2) (E.solve_for_x2 y)); intuition. - break_if; f_equal; apply E.point_eq. - + rewrite Bool.eqb_true_iff in Heqb. - pose proof (solve_onCurve y solve_sqrt_valid_p). - f_equal. - apply (sign_bit_match _ _ y); auto. - + rewrite Bool.eqb_false_iff in Heqb. - pose proof (solve_opp_onCurve y solve_sqrt_valid_p). - f_equal. - apply sign_bit_opp in Heqb. - apply (sign_bit_match _ _ y); auto. - intro eq_zero. - apply E.solve_correct in onCurve_p. - rewrite eq_zero in *. - rewrite Fq_pow_zero in solve_sqrt_valid_p by congruence. - rewrite <- solve_sqrt_valid_p in onCurve_p. - apply Fq_root_zero in onCurve_p. - rewrite onCurve_p in Heqb; auto. -Qed. - -(* Waiting on canonicalization *) -Lemma point_encoding_canonical : forall (x_enc : word (S sz)) (x : E.point), -point_dec x_enc = Some x -> point_enc x = x_enc. -Admitted. - -Instance point_encoding : canonical encoding of E.point as (word (S sz)) := { - enc := point_enc; - dec := point_dec; - encoding_valid := point_encoding_valid; - encoding_canonical := point_encoding_canonical -}. - -End PointEncoding. diff --git a/src/Experiments/DerivationsOptionRectLetInEncoding.v b/src/Experiments/DerivationsOptionRectLetInEncoding.v new file mode 100644 index 000000000..e5b74085e --- /dev/null +++ b/src/Experiments/DerivationsOptionRectLetInEncoding.v @@ -0,0 +1,351 @@ +Require Import Coq.omega.Omega. +Require Import Bedrock.Word. +Require Import Crypto.Spec.EdDSA. +Require Import Crypto.Tactics.VerdiTactics. +Require Import BinNat BinInt NArith Crypto.Spec.ModularArithmetic. +Require Import ModularArithmetic.ModularArithmeticTheorems. +Require Import ModularArithmetic.PrimeFieldTheorems. +Require Import Crypto.Spec.CompleteEdwardsCurve. +Require Import Crypto.Spec.Encoding Crypto.Spec.ModularWordEncoding. +Require Import Crypto.CompleteEdwardsCurve.ExtendedCoordinates. +Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. +Require Import Crypto.Util.IterAssocOp Crypto.Util.WordUtil. +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Classes.Equivalence. +Require Import Zdiv. +Require Import Crypto.Util.Tuple. +Local Open Scope equiv_scope. + +Generalizable All Variables. + + +Local Ltac set_evars := + repeat match goal with + | [ |- appcontext[?E] ] => is_evar E; let e := fresh "e" in set (e := E) + end. + +Local Ltac subst_evars := + repeat match goal with + | [ e := ?E |- _ ] => is_evar E; subst e + end. + +Definition path_sig {A P} {RA:relation A} {Rsig:relation (@sig A P)} + {HP:Proper (RA==>Basics.impl) P} + (H:forall (x y:A) (px:P x) (py:P y), RA x y -> Rsig (exist _ x px) (exist _ y py)) + (x : @sig A P) (y0:A) (pf : RA (proj1_sig x) y0) +: Rsig x (exist _ y0 (HP _ _ pf (proj2_sig x))). +Proof. destruct x. eapply H. assumption. Defined. + +Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y. +Global Instance Let_In_Proper_changebody {A P R} {Reflexive_R:@Reflexive P R} + : Proper (eq ==> pointwise_relation _ R ==> R) (@Let_In A (fun _ => P)). +Proof. + lazy; intros; try congruence. + subst; auto. +Qed. + +Lemma Let_In_Proper_changevalue {A B} RA {RB} (f:A->B) {Proper_f:Proper (RA==>RB) f} + : Proper (RA ==> RB) (fun x => Let_In x f). +Proof. intuition. Qed. + +Ltac fold_identity_lambdas := + repeat match goal with + | [ H: appcontext [fun x => ?f x] |- _ ] => change (fun x => f x) with f in * + | |- appcontext [fun x => ?f x] => change (fun x => f x) with f in * + end. + +Local Ltac replace_let_in_with_Let_In := + match goal with + | [ |- context G[let x := ?y in @?z x] ] + => let G' := context G[Let_In y z] in change G' + end. + +Local Ltac Let_In_app fn := + match goal with + | [ |- appcontext G[Let_In (fn ?x) ?f] ] + => change (Let_In (fn x) f) with (Let_In x (fun y => f (fn y))); cbv beta + end. + +Lemma if_map : forall {T U} (f:T->U) (b:bool) (x y:T), (if b then f x else f y) = f (if b then x else y). +Proof. + destruct b; trivial. +Qed. + +Lemma pull_Let_In {B C} (f : B -> C) A (v : A) (b : A -> B) + : Let_In v (fun v' => f (b v')) = f (Let_In v b). +Proof. + reflexivity. +Qed. + +Lemma Let_app_In {A B T} (g:A->B) (f:B->T) (x:A) : + @Let_In _ (fun _ => T) (g x) f = + @Let_In _ (fun _ => T) x (fun p => f (g x)). +Proof. reflexivity. Qed. + +Lemma Let_app_In' : forall {A B T} {R} {R_equiv:@Equivalence T R} + (g : A -> B) (f : B -> T) (x : A) + f' (f'_ok: forall z, f' z === f (g z)), + Let_In (g x) f === Let_In x f'. +Proof. intros; cbv [Let_In]; rewrite f'_ok; reflexivity. Qed. +Definition unfold_Let_In {A B} x (f:A->B) : Let_In x f = let y := x in f y := eq_refl. + +Lemma Let_app2_In {A B C D T} (g1:A->C) (g2:B->D) (f:C*D->T) (x:A) (y:B) : + @Let_In _ (fun _ => T) (g1 x, g2 y) f = + @Let_In _ (fun _ => T) (x, y) (fun p => f ((g1 (fst p), g2 (snd p)))). +Proof. reflexivity. Qed. + +Lemma funexp_proj {T T'} `{@Equivalence T' RT'} + (proj : T -> T') + (f : T -> T) + (f' : T' -> T') {Proper_f':Proper (RT'==>RT') f'} + (f_proj : forall a, proj (f a) === f' (proj a)) + x n + : proj (funexp f x n) === funexp f' (proj x) n. +Proof. + revert x; induction n as [|n IHn]; simpl; intros. + - reflexivity. + - rewrite f_proj. rewrite IHn. reflexivity. +Qed. + +Global Instance pair_Equivalence {A B} `{@Equivalence A RA} `{@Equivalence B RB} : @Equivalence (A*B) (fun x y => fst x = fst y /\ snd x === snd y). +Proof. + constructor; repeat intro; intuition; try congruence. + match goal with [H : _ |- _ ] => solve [rewrite H; auto] end. +Qed. + +Global Instance Proper_test_and_op {T scalar} `{Requiv:@Equivalence T RT} + {op:T->T->T} {Proper_op:Proper (RT==>RT==>RT) op} + {testbit:scalar->nat->bool} {s:scalar} {zero:T} : + let R := fun x y => fst x = fst y /\ snd x === snd y in + Proper (R==>R) (test_and_op op testbit s zero). +Proof. + unfold test_and_op; simpl; repeat intro; intuition; + repeat match goal with + | [ |- context[match ?n with _ => _ end] ] => destruct n eqn:?; simpl in *; subst; try discriminate; auto + | [ H: _ |- _ ] => setoid_rewrite H; reflexivity + end. +Qed. + +Lemma iter_op_proj {T T' S} `{T'Equiv:@Equivalence T' RT'} + (proj : T -> T') (op : T -> T -> T) (op' : T' -> T' -> T') {Proper_op':Proper (RT' ==> RT' ==> RT') op'} x y z + (testbit : S -> nat -> bool) (bound : nat) + (op_proj : forall a b, proj (op a b) === op' (proj a) (proj b)) + : proj (iter_op op x testbit y z bound) === iter_op op' (proj x) testbit y (proj z) bound. +Proof. + unfold iter_op. + lazymatch goal with + | [ |- ?proj (snd (funexp ?f ?x ?n)) === snd (funexp ?f' _ ?n) ] + => pose proof (fun pf x0 x1 => @funexp_proj _ _ _ _ (fun x' => (fst x', proj (snd x'))) f f' (Proper_test_and_op (Requiv:=T'Equiv)) pf (x0, x1)) as H'; + lazymatch type of H' with + | ?H'' -> _ => assert (H'') as pf; [clear H'|edestruct (H' pf); simpl in *; solve [eauto]] + end + end. + + intros [??]; simpl. + repeat match goal with + | [ |- context[match ?n with _ => _ end] ] => destruct n eqn:? + | _ => progress (unfold equiv; simpl) + | _ => progress (subst; intuition) + | _ => reflexivity + | _ => rewrite op_proj + end. +Qed. + +Global Instance option_rect_Proper_nd {A T} + : Proper ((pointwise_relation _ eq) ==> eq ==> eq ==> eq) (@option_rect A (fun _ => T)). +Proof. + intros ?? H ??? [|]??; subst; simpl; congruence. +Qed. + +Global Instance option_rect_Proper_nd' {A T} + : Proper ((pointwise_relation _ eq) ==> eq ==> forall_relation (fun _ => eq)) (@option_rect A (fun _ => T)). +Proof. + intros ?? H ??? [|]; subst; simpl; congruence. +Qed. + +Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?T))) => exact (@option_rect_Proper_nd' A T) : typeclass_instances. + +Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v, + option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v). +Proof. + destruct v; reflexivity. +Qed. + +Lemma option_rect_function {A B C S' N' v} f + : f (option_rect (fun _ : option A => option B) S' N' v) + = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v. +Proof. destruct v; reflexivity. Qed. +Local Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *) + idtac; + lazymatch goal with + | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ] + => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *) + cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta; + [ set_evars; + let H := fresh in + intro H; + rewrite H; + clear; + abstract (cbv [Let_In]; reflexivity) + | ] + end. + +(** TODO: possibly move me, remove local *) +Local Ltac replace_option_match_with_option_rect := + idtac; + lazymatch goal with + | [ |- _ = ?RHS :> ?T ] + => lazymatch RHS with + | match ?a with None => ?N | Some x => @?S x end + => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity) + end + end. +Local Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *) + repeat match goal with + | [ |- context[option_rect ?P ?S ?N None] ] + => change (option_rect P S N None) with N + | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ] + => change (option_rect P S N (Some x)) with (S x); cbv beta + end. + +Definition COMPILETIME {T} (x:T) : T := x. + +Lemma N_to_nat_le_mono : forall a b, (a <= b)%N -> (N.to_nat a <= N.to_nat b)%nat. +Proof. + intros. + pose proof (Nomega.Nlt_out a (N.succ b)). + rewrite N2Nat.inj_succ, N.lt_succ_r, <-NPeano.Nat.lt_succ_r in *; auto. +Qed. +Lemma N_size_nat_le_mono : forall a b, (a <= b)%N -> (N.size_nat a <= N.size_nat b)%nat. +Proof. + intros. + destruct (N.eq_dec a 0), (N.eq_dec b 0); try abstract (subst;rewrite ?N.le_0_r in *;subst;simpl;omega). + rewrite !Nsize_nat_equiv, !N.size_log2 by assumption. + edestruct N.succ_le_mono; eauto using N_to_nat_le_mono, N.log2_le_mono. +Qed. + +Lemma Z_to_N_Z_of_nat : forall n, Z.to_N (Z.of_nat n) = N.of_nat n. +Proof. induction n; auto. Qed. + +Lemma Z_of_nat_nonzero : forall m, m <> 0 -> (0 < Z.of_nat m)%Z. +Proof. intros. destruct m; [congruence|reflexivity]. Qed. + +Section with_unqualified_modulo. +Import NPeano Nat. +Local Infix "mod" := modulo : nat_scope. +Lemma N_of_nat_modulo : forall n m, m <> 0 -> N.of_nat (n mod m)%nat = (N.of_nat n mod N.of_nat m)%N. +Proof. + intros. + apply Znat.N2Z.inj_iff. + rewrite !Znat.nat_N_Z. + rewrite Zdiv.mod_Zmod by auto. + apply Znat.Z2N.inj_iff. + { apply Z.mod_pos_bound. apply Z_of_nat_nonzero. assumption. } + { apply Znat.N2Z.is_nonneg. } + rewrite Znat.Z2N.inj_mod by (auto using Znat.Nat2Z.is_nonneg, Z_of_nat_nonzero). + rewrite !Z_to_N_Z_of_nat, !Znat.N2Z.id; reflexivity. +Qed. +End with_unqualified_modulo. + +Lemma encoding_canonical' {T} {B} {encoding:canonical encoding of T as B} : + forall a b, enc a = enc b -> a = b. +Proof. + intros. + pose proof (f_equal dec H). + pose proof encoding_valid. + pose proof encoding_canonical. + congruence. +Qed. + +Lemma compare_encodings {T} {B} {encoding:canonical encoding of T as B} + (B_eqb:B->B->bool) (B_eqb_iff : forall a b:B, (B_eqb a b = true) <-> a = b) + : forall a b : T, (a = b) <-> (B_eqb (enc a) (enc b) = true). +Proof. + intros. + split; intro H. + { rewrite B_eqb_iff; congruence. } + { apply B_eqb_iff in H; eauto using encoding_canonical'. } +Qed. + +Lemma eqb_eq_dec' {T} (eqb:T->T->bool) (eqb_iff:forall a b, eqb a b = true <-> a = b) : + forall a b, if eqb a b then a = b else a <> b. +Proof. + intros. + case_eq (eqb a b); intros. + { eapply eqb_iff; trivial. } + { specialize (eqb_iff a b). rewrite H in eqb_iff. intuition. } +Qed. + +Definition eqb_eq_dec {T} (eqb:T->T->bool) (eqb_iff:forall a b, eqb a b = true <-> a = b) : + forall a b : T, {a=b}+{a<>b}. +Proof. + intros. + pose proof (eqb_eq_dec' eqb eqb_iff a b). + destruct (eqb a b); eauto. +Qed. + +Definition eqb_eq_dec_and_output {T} (eqb:T->T->bool) (eqb_iff:forall a b, eqb a b = true <-> a = b) : + forall a b : T, {a = b /\ eqb a b = true}+{a<>b /\ eqb a b = false}. +Proof. + intros. + pose proof (eqb_eq_dec' eqb eqb_iff a b). + destruct (eqb a b); eauto. +Qed. + +Lemma eqb_compare_encodings {T} {B} {encoding:canonical encoding of T as B} + (T_eqb:T->T->bool) (T_eqb_iff : forall a b:T, (T_eqb a b = true) <-> a = b) + (B_eqb:B->B->bool) (B_eqb_iff : forall a b:B, (B_eqb a b = true) <-> a = b) + : forall a b : T, T_eqb a b = B_eqb (enc a) (enc b). +Proof. + intros; + destruct (eqb_eq_dec_and_output T_eqb T_eqb_iff a b); + destruct (eqb_eq_dec_and_output B_eqb B_eqb_iff (enc a) (enc b)); + intuition; + try find_copy_apply_lem_hyp B_eqb_iff; + try find_copy_apply_lem_hyp T_eqb_iff; + try congruence. + apply (compare_encodings B_eqb B_eqb_iff) in H2; congruence. +Qed. + +Lemma decode_failed_neq_encoding {T B} (encoding_T_B:canonical encoding of T as B) (X:B) + (dec_failed:dec X = None) (a:T) : X <> enc a. +Proof. pose proof encoding_valid. congruence. Qed. +Lemma compare_without_decoding {T B} (encoding_T_B:canonical encoding of T as B) + (T_eqb:T->T->bool) (T_eqb_iff:forall a b, T_eqb a b = true <-> a = b) + (B_eqb:B->B->bool) (B_eqb_iff:forall a b, B_eqb a b = true <-> a = b) + (P_:B) (Q:T) : + option_rect (fun _ : option T => bool) + (fun P : T => T_eqb P Q) + false + (dec P_) + = B_eqb P_ (enc Q). +Proof. + destruct (dec P_) eqn:Hdec; simpl option_rect. + { apply encoding_canonical in Hdec; subst; auto using eqb_compare_encodings. } + { pose proof encoding_canonical. + pose proof encoding_valid. + pose proof eqb_compare_encodings. + eapply decode_failed_neq_encoding in Hdec. + destruct (B_eqb P_ (enc Q)) eqn:Heq; [rewrite B_eqb_iff in Heq; eauto | trivial]. } +Qed. + +Lemma unfoldDiv : forall {m} (x y:F m), (x/y = x * inv y)%F. Proof. unfold div. congruence. Qed. + +Definition FieldToN {m} (x:F m) := Z.to_N (FieldToZ x). +Lemma FieldToN_correct {m} (x:F m) : FieldToN (m:=m) x = Z.to_N (FieldToZ x). reflexivity. Qed. + +Definition natToField {m} x : F m := ZToField (Z.of_nat x). +Definition FieldToNat {m} (x:F m) : nat := Z.to_nat (FieldToZ x). + +Section with_unqualified_modulo2. +Import NPeano Nat. +Local Infix "mod" := modulo : nat_scope. +Lemma FieldToNat_natToField {m} : m <> 0 -> forall x, x mod m = FieldToNat (natToField (m:=Z.of_nat m) x). + unfold natToField, FieldToNat; intros. + rewrite (FieldToZ_ZToField), <-mod_Zmod, Nat2Z.id; trivial. +Qed. +End with_unqualified_modulo2. + +Lemma F_eqb_iff {q} : forall x y : F q, F_eqb x y = true <-> x = y. +Proof. + split; eauto using F_eqb_eq, F_eqb_complete. +Qed. diff --git a/src/Experiments/GenericFieldPow.v b/src/Experiments/GenericFieldPow.v new file mode 100644 index 000000000..33d524567 --- /dev/null +++ b/src/Experiments/GenericFieldPow.v @@ -0,0 +1,337 @@ +Require Import Coq.setoid_ring.Cring. +Require Import Coq.omega.Omega. +Generalizable All Variables. + + +(*TODO: move *) +Lemma Z_pos_pred_0 p : Z.pos p - 1 = 0 -> p=1%positive. +Proof. destruct p; simpl in *; try discriminate; auto. Qed. + +Lemma Z_neg_succ_neg : forall a b, (Z.neg a + 1)%Z = Z.neg b -> a = Pos.succ b. +Admitted. + +Lemma Z_pos_pred_pos : forall a b, (Z.pos a - 1)%Z = Z.pos b -> a = Pos.succ b. +Admitted. + +Lemma Z_pred_neg p : (Z.neg p - 1)%Z = Z.neg (Pos.succ p). +Admitted. + +(* teach nsatz to deal with the definition of power we are use *) +Instance reify_pow_pos (R:Type) `{Ring R} +e1 lvar t1 n +`{Ring (T:=R)} +{_:reify e1 lvar t1} +: reify (PEpow e1 (N.pos n)) lvar (pow_pos t1 n)|1. + +Class Field_ops (F:Type) + `{Ring_ops F} + {inv:F->F} := {}. + +Class Division (A B C:Type) := division : A -> B -> C. + +Local Notation "_/_" := division. +Local Notation "n / d" := (division n d). + +Module F. + + Definition div `{Field_ops F} n d := n * (inv d). + Global Instance div_notation `{Field_ops F} : @Division F F F := div. + + Class Field {F inv} `{FieldCring:Cring (R:=F)} {Fo:Field_ops F (inv:=inv)} := + { + field_inv_comp : Proper (_==_ ==> _==_) inv; + field_inv_def : forall x, (x == 0 -> False) -> inv x * x == 1; + field_one_neq_zero : not (1 == 0) + }. + Global Existing Instance field_inv_comp. + + Definition powZ `{Field_ops F} (x:F) (n:Z) := + match n with + | Z0 => 1 + | Zpos p => pow_pos x p + | Zneg p => inv (pow_pos x p) + end. + Global Instance power_field `{Field_ops F} : Power | 5 := { power := powZ }. + + Section FieldProofs. + Context `{Field F}. + + Definition unfold_div (x y:F) : x/y = x * inv y := eq_refl. + + Global Instance Proper_div : + Proper (_==_ ==> _==_ ==> _==_) div. + Proof. + unfold div; repeat intro. + repeat match goal with + | [H: _ == _ |- _ ] => rewrite H; clear H + end; reflexivity. + Qed. + + Global Instance Proper_pow_pos : Proper (_==_==>eq==>_==_) pow_pos. + Proof. + cut (forall n (y x : F), x == y -> pow_pos x n == pow_pos y n); + [repeat intro; subst; eauto|]. + induction n; simpl; intros; trivial; + repeat eapply ring_mult_comp; eauto. + Qed. + + Global Instance Propper_powZ : Proper (_==_==>eq==>_==_) powZ. + Proof. + repeat intro; subst; unfold powZ. + match goal with |- context[match ?x with _ => _ end] => destruct x end; + repeat (eapply Proper_pow_pos || f_equiv; trivial). + Qed. + + Require Import Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac. + Lemma field_theory_for_tactic : field_theory 0 1 _+_ _*_ _-_ -_ _/_ inv _==_. + Proof. + split; repeat constructor; repeat intro; gen_rewrite; try cring; + eauto using field_one_neq_zero, field_inv_def. Qed. + + Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.NArithRing. + Lemma power_theory_for_tactic : power_theory 1 _*_ _==_ NtoZ power. + Proof. constructor; destruct n; reflexivity. Qed. + + Create HintDb field_nonzero discriminated. + Hint Resolve field_one_neq_zero : field_nonzero. + Ltac field_nonzero := repeat split; auto 3 with field_nonzero. + Ltac field_power_isconst t := Ncst t. + Add Field FieldProofsAddField : field_theory_for_tactic + (postprocess [field_nonzero], + power_tac power_theory_for_tactic [field_power_isconst]). + + Lemma div_mul_idemp_l : forall a b, (a==0 -> False) -> a*b/a == b. + Proof. intros. field. Qed. + + Context {eq_dec:forall x y : F, {x==y}+{x==y->False}}. + Lemma mul_zero_why : forall a b, a*b == 0 -> a == 0 \/ b == 0. + intros; destruct (eq_dec a 0); intuition. + assert (a * b / a == 0) by + (match goal with [H: _ == _ |- _ ] => rewrite H; field end). + rewrite div_mul_idemp_l in *; auto. + Qed. + + Require Import Coq.nsatz.Nsatz. + Global Instance Integral_domain_Field : Integral_domain (R:=F). + Proof. + constructor; intros; eauto using mul_zero_why, field_one_neq_zero. + Qed. + + Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := + let t := type of H in + generalize H; + field_lookup (PackField FIELD_SIMPL_EQ) [] t; + try (exact I); + try (idtac; []; clear H;intro H). + + Require Import Util.Tactics. + Inductive field_simplify_done {x y:F} : (x==y) -> Type := + Field_simplify_done : forall (H:x==y), field_simplify_done H. + Ltac field_nsatz := + repeat match goal with + [ H: (_:F) == _ |- _ ] => + match goal with + | [ Ha : field_simplify_done H |- _ ] => fail + | _ => idtac + end; + field_simplify_eq in H; + unique pose proof (Field_simplify_done H) + end; + repeat match goal with [ H: field_simplify_done _ |- _] => clear H end; + try field_simplify_eq; + try nsatz. + + Create HintDb field discriminated. + Hint Extern 5 (_ == _) => field_nsatz : field. + Hint Extern 5 (_ <-> _) => split. + + Lemma mul_inv_l : forall x, not (x == 0) -> inv x * x == 1. Proof. auto with field. Qed. + + Lemma mul_inv_r : forall x, not (x == 0) -> x * inv x == 1. Proof. auto with field. Qed. + + Lemma mul_cancel_r' (x y z:F) : not (z == 0) -> x * z == y * z -> x == y. + Proof. + intros. + assert (x * z * inv z == y * z * inv z) by + (match goal with [H: _ == _ |- _ ] => rewrite H; auto with field end). + assert (x * z * inv z == x * (z * inv z)) by auto with field. + assert (y * z * inv z == y * (z * inv z)) by auto with field. + rewrite mul_inv_r, @ring_mul_1_r in *; auto with field. + Qed. + + Lemma mul_cancel_r (x y z:F) : not (z == 0) -> (x * z == y * z <-> x == y). + Proof. intros;split;intros Heq; try eapply mul_cancel_r' in Heq; eauto with field. Qed. + + Lemma mul_cancel_l (x y z:F) : not (z == 0) -> (z * x == z * y <-> x == y). + Proof. intros;split;intros; try eapply mul_cancel_r; eauto with field. Qed. + + Lemma mul_cancel_r_eq : forall x z:F, not(z==0) -> (x*z == z <-> x == 1). + Proof. + intros;split;intros Heq; [|nsatz]. + pose proof ring_mul_1_l z as Hz; rewrite <- Hz in Heq at 2; rewrite mul_cancel_r in Heq; eauto. + Qed. + + Lemma mul_cancel_l_eq : forall x z:F, not(z==0) -> (z*x == z <-> x == 1). + Proof. intros;split;intros Heq; try eapply mul_cancel_r_eq; eauto with field. Qed. + + Lemma inv_unique (a:F) : forall x y, x * a == 1 -> y * a == 1 -> x == y. Proof. auto with field. Qed. + + Lemma mul_nonzero_nonzero (a b:F) : not (a == 0) -> not (b == 0) -> not (a*b == 0). + Proof. intros; intro Hab. destruct (mul_zero_why _ _ Hab); auto. Qed. + Hint Resolve mul_nonzero_nonzero : field_nonzero. + + Lemma inv_nonzero (x:F) : not(x == 0) -> not(inv x==0). + Proof. + intros Hx Hi. + assert (Hc:not (inv x*x==0)) by (rewrite field_inv_def; eauto with field_nonzero); contradict Hc. + ring [Hi]. + Qed. + Hint Resolve inv_nonzero : field_nonzero. + + Lemma div_nonzero (x y:F) : not(x==0) -> not(y==0) -> not(x/y==0). + Proof. + unfold division, div_notation, div; auto with field_nonzero. + Qed. + Hint Resolve div_nonzero : field_nonzero. + + Lemma pow_pos_nonzero (x:F) p : not(x==0) -> not(Ncring.pow_pos x p == 0). + Proof. + intros; induction p using Pos.peano_ind; try assumption; []. + rewrite Ncring.pow_pos_succ; eauto using mul_nonzero_nonzero. + Qed. + Hint Resolve pow_pos_nonzero : field_nonzero. + + Lemma sub_diag_iff (x y:F) : x - y == 0 <-> x == y. Proof. auto with field. Qed. + + Lemma mul_same (x:F) : x*x == x^2%Z. Proof. auto with field. Qed. + + Lemma inv_mul (x y:F) : not(x==0) -> not (y==0) -> inv (x*y) == inv x * inv y. + Proof. intros;field;intuition. Qed. + + Lemma pow_0_r (x:F) : x^0 == 1. Proof. auto with field. Qed. + Lemma pow_1_r : forall x:F, x^1%Z == x. Proof. auto with field. Qed. + Lemma pow_2_r : forall x:F, x^2%Z == x*x. Proof. auto with field. Qed. + Lemma pow_3_r : forall x:F, x^3%Z == x*x*x. Proof. auto with field. Qed. + + Lemma pow_succ_r (x:F) (n:Z) : not (x==0)\/(n>=0)%Z -> x^(n+1) == x * x^n. + Proof. + intros Hnz; unfold power, powZ, power_field, powZ; destruct n eqn:HSn. + - simpl; ring. + - setoid_rewrite <-Pos2Z.inj_succ; rewrite Ncring.pow_pos_succ; ring. + - destruct (Z.succ (Z.neg p)) eqn:Hn. + + assert (p=1%positive) by (destruct p; simpl in *; try discriminate; auto). + subst; simpl in *; field. destruct Hnz; auto with field_nonzero. + + destruct p, p0; discriminate. + + setoid_rewrite Hn. + apply Z_neg_succ_neg in Hn; subst. + rewrite Ncring.pow_pos_succ; field; + destruct Hnz; auto with field_nonzero. + Qed. + + Lemma pow_pred_r (x:F) (n:Z) : not (x==0) -> x^(n-1) == x^n/x. + Proof. + intros; unfold power, powZ, power_field, powZ; destruct n eqn:HSn. + - simpl. rewrite unfold_div; field. + - destruct (Z.pos p - 1) eqn:Hn. + + apply Z_pos_pred_0 in Hn; subst; simpl; field. + + apply Z_pos_pred_pos in Hn; subst. + rewrite Ncring.pow_pos_succ; field; auto with field_nonzero. + + destruct p; discriminate. + - rewrite Z_pred_neg, Ncring.pow_pos_succ; field; auto with field_nonzero. + Qed. + + Local Ltac pow_peano := + repeat (setoid_rewrite pow_0_r + || setoid_rewrite pow_succ_r + || setoid_rewrite pow_pred_r). + + Lemma pow_mul (x y:F) : forall (n:Z), not(x==0)/\not(y==0)\/(n>=0)%Z -> (x * y)^n == x^n * y^n. + Proof. + match goal with |- forall n, @?P n => eapply (Z.order_induction'_0 P) end. + { repeat intro. subst. reflexivity. } + - intros; cbv [power power_field powZ]; ring. + - intros n Hn IH Hxy. + repeat setoid_rewrite pow_succ_r; try rewrite IH; try ring; (right; omega). + - intros n Hn IH Hxy. destruct Hxy as [[]|?]; try omega; []. + repeat setoid_rewrite pow_pred_r; try rewrite IH; try field; auto with field_nonzero. + Qed. + + Lemma pow_nonzero (x:F) : forall (n:Z), not(x==0) -> not(x^n==0). + match goal with |- forall n, @?P n => eapply (Z.order_induction'_0 P) end; intros; pow_peano; + eauto with field_nonzero. + { repeat intro. subst. reflexivity. } + Qed. + Hint Resolve pow_nonzero : field_nonzero. + + Lemma pow_inv (x:F) : forall (n:Z), not(x==0) -> inv x^n == inv (x^n). + match goal with |- forall n, @?P n => eapply (Z.order_induction'_0 P) end. + { repeat intro. subst. reflexivity. } + - intros; cbv [power power_field powZ]. field; eauto with field_nonzero. + - intros n Hn IH Hx. + repeat setoid_rewrite pow_succ_r; try rewrite IH; try field; eauto with field_nonzero. + - intros n Hn IH Hx. + repeat setoid_rewrite pow_pred_r; try rewrite IH; try field; eauto 3 with field_nonzero. + Qed. + + Lemma pow_0_l : forall n, (n>0)%Z -> (0:F)^n==0. + match goal with |- forall n, @?P n => eapply (Z.order_induction'_0 P) end; intros; try omega. + { repeat intro. subst. reflexivity. } + setoid_rewrite pow_succ_r; [auto with field|right;omega]. + Qed. + + Lemma pow_div (x y:F) (n:Z) : not (y==0) -> not(x==0)\/(n >= 0)%Z -> (x/y)^n == x^n/y^n. + Proof. + intros Hy Hxn. unfold division, div_notation, div. + rewrite pow_mul, pow_inv; try field; destruct Hxn; auto with field_nonzero. + Qed. + + Hint Extern 3 (_ >= _)%Z => omega : field_nonzero. + Lemma issquare_mul (x y z:F) : not (y == 0) -> x^2%Z == z * y^2%Z -> (x/y)^2%Z == z. + Proof. intros. rewrite pow_div by (auto with field_nonzero); auto with field. Qed. + + Lemma issquare_mul_sub (x y z:F) : 0 == z*y^2%Z - x^2%Z -> (x/y)^2%Z == z \/ x == 0. + Proof. destruct (eq_dec y 0); [right|left]; auto using issquare_mul with field. Qed. + + Lemma div_mul : forall x y z : F, not(y==0) -> (z == (x / y) <-> z * y == x). + Proof. auto with field. Qed. + + Lemma div_1_r : forall x : F, x/1 == x. + Proof. eauto with field field_nonzero. Qed. + + Lemma div_1_l : forall x : F, not(x==0) -> 1/x == inv x. + Proof. auto with field. Qed. + + Lemma div_opp_l : forall x y, not (y==0) -> (-_ x) / y == -_ (x / y). + Proof. auto with field. Qed. + + Lemma div_opp_r : forall x y, not (y==0) -> x / (-_ y) == -_ (x / y). + Proof. auto with field. Qed. + + Lemma eq_opp_zero : forall x : F, (~ 1 + 1 == (0:F)) -> (x == -_ x <-> x == 0). + Proof. auto with field. Qed. + + Lemma add_cancel_l : forall x y z:F, z+x == z+y <-> x == y. + Proof. auto with field. Qed. + + Lemma add_cancel_r : forall x y z:F, x+z == y+z <-> x == y. + Proof. auto with field. Qed. + + Lemma add_cancel_r_eq : forall x z:F, x+z == z <-> x == 0. + Proof. auto with field. Qed. + + Lemma add_cancel_l_eq : forall x z:F, z+x == z <-> x == 0. + Proof. auto with field. Qed. + + Lemma sqrt_solutions : forall x y:F, y ^ 2%Z == x ^ 2%Z -> y == x \/ y == -_ x. + Proof. + intros ? ? squares_eq. + remember (y - x) as z eqn:Heqz. + assert (y == x + z) as Heqy by (subst; ring); rewrite Heqy in *; clear Heqy Heqz. + assert (Hw:(x + z)^2%Z == z * (x + (x + z)) + x^2%Z) + by (auto with field); rewrite Hw in squares_eq; clear Hw. + rewrite add_cancel_r_eq in squares_eq. + apply mul_zero_why in squares_eq; destruct squares_eq; auto with field. + Qed. + + End FieldProofs. +End F. diff --git a/src/Spec/Ed25519.v b/src/Experiments/SpecEd25519.v index 4876bb8d1..4e30313d9 100644 --- a/src/Spec/Ed25519.v +++ b/src/Experiments/SpecEd25519.v @@ -1,6 +1,6 @@ Require Import Coq.ZArith.ZArith Coq.ZArith.Zpower Coq.ZArith.ZArith Coq.ZArith.Znumtheory. Require Import Coq.Numbers.Natural.Peano.NPeano Coq.NArith.NArith. -Require Import Crypto.Spec.PointEncoding Crypto.Spec.ModularWordEncoding. +Require Import Crypto.Spec.ModularWordEncoding. Require Import Crypto.Encoding.ModularWordEncodingTheorems. Require Import Crypto.Spec.EdDSA. Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. @@ -13,7 +13,7 @@ Require Import Coq.omega.Omega. Local Open Scope nat_scope. Definition q : Z := (2 ^ 255 - 19)%Z. -Lemma prime_q : prime q. Admitted. +Global Instance prime_q : prime q. Admitted. Lemma two_lt_q : (2 < q)%Z. reflexivity. Qed. Definition a : F q := opp 1%F. @@ -65,24 +65,23 @@ Lemma nonsquare_d : forall x, (x^2 <> d)%F. exact eq_refl. Qed. (* 10s *) -Instance curve25519params : TwistedEdwardsParams := { - q := q; - prime_q := prime_q; - two_lt_q := two_lt_q; - a := a; - nonzero_a := nonzero_a; - square_a := square_a; - d := d; - nonsquare_d := nonsquare_d -}. +Instance curve25519params : @E.twisted_edwards_params (F q) eq (ZToField 0) (ZToField 1) add mul a d := + { + nonzero_a := nonzero_a + (* TODO:port + char_gt_2 : ~ Feq (Fadd Fone Fone) Fzero; + nonzero_a : ~ Feq a Fzero; + nonsquare_d : forall x : F, ~ Feq (Fmul x x) d } + *) + }. +Admitted. Lemma two_power_nat_Z2Nat : forall n, Z.to_nat (two_power_nat n) = 2 ^ n. Admitted. Definition b := 256. -Lemma b_valid : (2 ^ (b - 1) > Z.to_nat CompleteEdwardsCurve.q)%nat. +Lemma b_valid : (2 ^ (b - 1) > Z.to_nat q)%nat. Proof. - replace (CompleteEdwardsCurve.q) with q by reflexivity. unfold q, gt. replace (2 ^ (b - 1)) with (Z.to_nat (2 ^ (Z.of_nat (b - 1)))) by (rewrite <- two_power_nat_equiv; apply two_power_nat_Z2Nat). @@ -143,37 +142,24 @@ Proof. reflexivity. Qed. -Definition PointEncoding : canonical encoding of E.point as (word b) := - (@point_encoding curve25519params (b - 1) q_5mod8 sqrt_minus1_valid FqEncoding sign_bit - (@sign_bit_zero _ prime_q two_lt_q _ b_valid) (@sign_bit_opp _ prime_q two_lt_q _ b_valid)). - -Definition H : forall n : nat, word n -> word (b + b). Admitted. -Definition B : E.point. Admitted. (* TODO: B = decodePoint (y=4/5, x="positive") *) -Definition B_nonzero : B <> E.zero. Admitted. -Definition l_order_B : (l * B)%E = E.zero. Admitted. - -Local Instance ed25519params : EdDSAParams := { - E := curve25519params; - b := b; - H := H; - c := c; - n := n; - B := B; - l := l; - FqEncoding := FqEncoding; - FlEncoding := FlEncoding; - PointEncoding := PointEncoding; - - b_valid := b_valid; - c_valid := c_valid; - n_ge_c := n_ge_c; - n_le_b := n_le_b; - B_not_identity := B_nonzero; - l_prime := prime_l; - l_odd := l_odd; - l_order_B := l_order_B -}. - -Definition ed25519_verify - : forall (pubkey:word b) (len:nat) (msg:word len) (sig:word (b+b)), bool - := @verify ed25519params.
\ No newline at end of file +Local Notation point := (@E.point (F q) eq (ZToField 1) add mul a d). +Local Notation zero := (E.zero(H:=field_modulo)). +Local Notation add := (E.add(H0:=curve25519params)). +Local Infix "*" := (E.mul(H0:=curve25519params)). +Axiom H : forall n : nat, word n -> word (b + b). +Axiom B : point. (* TODO: B = decodePoint (y=4/5, x="positive") *) +Axiom B_nonzero : B <> zero. +Axiom l_order_B : l * B = zero. +Axiom point_encoding : canonical encoding of point as word b. +Axiom scalar_encoding : canonical encoding of {n : nat | n < l} as word b. + +Global Instance Ed25519 : @EdDSA point E.eq add zero E.opp E.mul b H c n l B point_encoding scalar_encoding := + { + EdDSA_c_valid := c_valid; + EdDSA_n_ge_c := n_ge_c; + EdDSA_n_le_b := n_le_b; + EdDSA_B_not_identity := B_nonzero; + EdDSA_l_prime := prime_l; + EdDSA_l_odd := l_odd; + EdDSA_l_order_B := l_order_B + }.
\ No newline at end of file diff --git a/src/ModularArithmetic/ExtendedBaseVector.v b/src/ModularArithmetic/ExtendedBaseVector.v index 2e65df9bd..9ed7d065e 100644 --- a/src/ModularArithmetic/ExtendedBaseVector.v +++ b/src/ModularArithmetic/ExtendedBaseVector.v @@ -22,19 +22,19 @@ Section ExtendedBaseVector. * * (x \dot base) * (y \dot base) = (z \dot ext_base) * - * Then we can separate z into its first and second halves: + * Then we can separate z into its first and second halves: * * (z \dot ext_base) = (z1 \dot base) + (2 ^ k) * (z2 \dot base) * * Now, if we want to reduce the product modulo 2 ^ k - c: - * + * * (z \dot ext_base) mod (2^k-c)= (z1 \dot base) + (2 ^ k) * (z2 \dot base) mod (2^k-c) * (z \dot ext_base) mod (2^k-c)= (z1 \dot base) + c * (z2 \dot base) mod (2^k-c) * * This sum may be short enough to express using base; if not, we can reduce again. *) Definition ext_base := base ++ (map (Z.mul (2^k)) base). - + Lemma ext_base_positive : forall b, In b ext_base -> b > 0. Proof. unfold ext_base. intros b In_b_base. @@ -76,14 +76,14 @@ Section ExtendedBaseVector. intuition. Qed. - Lemma map_nth_default_base_high : forall n, (n < (length base))%nat -> + Lemma map_nth_default_base_high : forall n, (n < (length base))%nat -> nth_default 0 (map (Z.mul (2 ^ k)) base) n = (2 ^ k) * (nth_default 0 base n). Proof. intros. erewrite map_nth_default; auto. Qed. - + Lemma base_good_over_boundary : forall (i : nat) (l : (i < length base)%nat) diff --git a/src/ModularArithmetic/FField.v b/src/ModularArithmetic/FField.v deleted file mode 100644 index 4f2b623e0..000000000 --- a/src/ModularArithmetic/FField.v +++ /dev/null @@ -1,63 +0,0 @@ -Require Export Crypto.Spec.ModularArithmetic. -Require Export Coq.setoid_ring.Field. - -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. - -Local Open Scope F_scope. - -Definition OpaqueF := F. -Definition OpaqueZmodulo := BinInt.Z.modulo. -Definition Opaqueadd {p} : OpaqueF p -> OpaqueF p -> OpaqueF p := @add p. -Definition Opaquemul {p} : OpaqueF p -> OpaqueF p -> OpaqueF p := @mul p. -Definition Opaquesub {p} : OpaqueF p -> OpaqueF p -> OpaqueF p := @sub p. -Definition Opaquediv {p} : OpaqueF p -> OpaqueF p -> OpaqueF p := @div p. -Definition Opaqueopp {p} : OpaqueF p -> OpaqueF p := @opp p. -Definition Opaqueinv {p} : OpaqueF p -> OpaqueF p := @inv p. -Definition OpaqueZToField {p} : BinInt.Z -> OpaqueF p := @ZToField p. -Definition Opaqueadd_correct {p} : @Opaqueadd p = @add p := eq_refl. -Definition Opaquesub_correct {p} : @Opaquesub p = @sub p := eq_refl. -Definition Opaquemul_correct {p} : @Opaquemul p = @mul p := eq_refl. -Definition Opaquediv_correct {p} : @Opaquediv p = @div p := eq_refl. -Global Opaque F OpaqueZmodulo Opaqueadd Opaquemul Opaquesub Opaquediv Opaqueopp Opaqueinv OpaqueZToField. - -Definition OpaqueFieldTheory p {prime_p} : @field_theory (OpaqueF p) (OpaqueZToField 0%Z) (OpaqueZToField 1%Z) Opaqueadd Opaquemul Opaquesub Opaqueopp Opaquediv Opaqueinv eq := Eval hnf in @Ffield_theory p prime_p. - -Ltac FIELD_SIMPL_idtac FLD lH rl := - let Simpl := idtac (* (protect_fv "field") *) in - let lemma := get_SimplifyEqLemma FLD in - get_FldPre FLD (); - Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; - get_FldPost FLD (). -Ltac field_simplify_eq_idtac := let G := Get_goal in field_lookup (PackField FIELD_SIMPL_idtac) [] G. - -Ltac F_to_Opaque := - change F with OpaqueF in *; - change BinInt.Z.modulo with OpaqueZmodulo in *; - change @add with @Opaqueadd in *; - change @mul with @Opaquemul in *; - change @sub with @Opaquesub in *; - change @div with @Opaquediv in *; - change @opp with @Opaqueopp in *; - change @inv with @Opaqueinv in *; - change @ZToField with @OpaqueZToField in *. - -Ltac F_from_Opaque p := - change OpaqueF with F in *; - change (@sig BinNums.Z (fun z : BinNums.Z => @eq BinNums.Z z (BinInt.Z.modulo z p))) with (F p) in *; - change OpaqueZmodulo with BinInt.Z.modulo in *; - change @Opaqueopp with @opp in *; - change @Opaqueinv with @inv in *; - change @OpaqueZToField with @ZToField in *; - rewrite ?@Opaqueadd_correct, ?@Opaquesub_correct, ?@Opaquemul_correct, ?@Opaquediv_correct in *. - -Ltac F_field_simplify_eq := - lazymatch goal with |- @eq (F ?p) _ _ => - F_to_Opaque; - field_simplify_eq_idtac; - compute; - F_from_Opaque p - end. - -Ltac F_field := F_field_simplify_eq; [ring|..]. - -Ltac notConstant t := constr:NotConstant. diff --git a/src/ModularArithmetic/FNsatz.v b/src/ModularArithmetic/FNsatz.v deleted file mode 100644 index 221b8d799..000000000 --- a/src/ModularArithmetic/FNsatz.v +++ /dev/null @@ -1,40 +0,0 @@ -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Require Export Crypto.ModularArithmetic.FField. -Require Import Coq.nsatz.Nsatz. - -Ltac FqAsIntegralDomain := - lazymatch goal with [H:Znumtheory.prime ?q |- _ ] => - pose proof (_:@Integral_domain.Integral_domain (F q) _ _ _ _ _ _ _ _ _ _) as FqIntegralDomain; - lazymatch type of FqIntegralDomain with @Integral_domain.Integral_domain _ _ _ _ _ _ _ _ ?ringOps ?ringOk ?ringComm => - generalize dependent ringComm; intro Cring; - generalize dependent ringOk; intro Ring; - generalize dependent ringOps; intro RingOps; - lazymatch type of RingOps with @Ncring.Ring_ops ?t ?z ?o ?a ?m ?s ?p ?e => - generalize dependent e; intro equiv; - generalize dependent p; intro opp; - generalize dependent s; intro sub; - generalize dependent m; intro mul; - generalize dependent a; intro add; - generalize dependent o; intro one; - generalize dependent z; intro zero; - generalize dependent t; intro R - end - end; intros; - clear q H - end. - -Ltac fixed_equality_to_goal H x y := generalize (psos_r1 x y H); clear H. -Ltac fixed_equalities_to_goal := - match goal with - | H:?x == ?y |- _ => fixed_equality_to_goal H x y - | H:_ ?x ?y |- _ => fixed_equality_to_goal H x y - | H:_ _ ?x ?y |- _ => fixed_equality_to_goal H x y - | H:_ _ _ ?x ?y |- _ => fixed_equality_to_goal H x y - | H:_ _ _ _ ?x ?y |- _ => fixed_equality_to_goal H x y - end. -Ltac fixed_nsatz := - intros; try apply psos_r1b; - lazymatch goal with - | |- @equality ?T _ _ _ => repeat fixed_equalities_to_goal; nsatz_generic 6%N 1%Z (@nil T) (@nil T) - end. -Ltac F_nsatz := abstract (FqAsIntegralDomain; fixed_nsatz). diff --git a/src/ModularArithmetic/ModularArithmeticTheorems.v b/src/ModularArithmetic/ModularArithmeticTheorems.v index dabfcf883..8e526745c 100644 --- a/src/ModularArithmetic/ModularArithmeticTheorems.v +++ b/src/ModularArithmetic/ModularArithmeticTheorems.v @@ -1,3 +1,4 @@ +Require Import Coq.omega.Omega. Require Import Crypto.Spec.ModularArithmetic. Require Import Crypto.ModularArithmetic.Pre. @@ -10,7 +11,7 @@ Require Export Crypto.Util.IterAssocOp. Section ModularArithmeticPreliminaries. Context {m:Z}. - Local Coercion ZToFm := ZToField : BinNums.Z -> F m. Hint Unfold ZToFm. + Let ZToFm := ZToField : BinNums.Z -> F m. Hint Unfold ZToFm. Local Coercion ZToFm : Z >-> F. Theorem F_eq: forall (x y : F m), x = y <-> FieldToZ x = FieldToZ y. Proof. @@ -19,20 +20,20 @@ Section ModularArithmeticPreliminaries. f_equal. eapply UIP_dec, Z.eq_dec. Qed. - + Lemma F_opp_spec : forall (a:F m), add a (opp a) = 0. intros a. pose (@opp_with_spec m) as H. - change (@opp m) with (proj1_sig H). + change (@opp m) with (proj1_sig H). destruct H; eauto. Qed. - + Lemma F_pow_spec : forall (a:F m), pow a 0%N = 1%F /\ forall x, pow a (1 + x)%N = mul a (pow a x). Proof. intros a. pose (@pow_with_spec m) as H. - change (@pow m) with (proj1_sig H). + change (@pow m) with (proj1_sig H). destruct H; eauto. Qed. End ModularArithmeticPreliminaries. @@ -81,7 +82,7 @@ Ltac eq_remove_proofs := lazymatch goal with assert (Q := F_eq a b); simpl in *; apply Q; clear Q end. - + Ltac Fdefn := intros; rewrite ?F_opp_spec; @@ -149,6 +150,15 @@ Section FandZ. intuition; find_inversion; rewrite ?Z.mod_0_l, ?Z.mod_small in *; intuition. Qed. + Require Crypto.Algebra. + Global Instance commutative_ring_modulo : @Algebra.commutative_ring (F m) Logic.eq (ZToField 0) (ZToField 1) opp add sub mul. + Proof. + repeat split; Fdefn; try apply F_eq_dec. + { rewrite Z.add_0_r. auto. } + { rewrite <-Z.add_sub_swap, <-Z.add_sub_assoc, Z.sub_diag, Z.add_0_r. apply Z_mod_same_full. } + { rewrite Z.mul_1_r. auto. } + Qed. + Lemma ZToField_0 : @ZToField m 0 = 0. Proof. Fdefn. @@ -217,7 +227,7 @@ Section FandZ. rewrite ?N2Nat.inj_succ, ?pow_0, <-?N.add_1_l, ?pow_succ; simpl; congruence. Qed. - + Lemma mod_plus_zero_subproof a b : 0 mod m = (a + b) mod m -> b mod m = (- a) mod m. Proof. @@ -244,7 +254,7 @@ Section FandZ. intros. pose proof (FieldToZ_opp' x) as H; rewrite mod_FieldToZ in H; trivial. Qed. - + Lemma sub_intersperse_modulus : forall x y, ((x - y) mod m = (x + (m - y)) mod m)%Z. Proof. intros. @@ -282,7 +292,7 @@ Section FandZ. Proof. Fdefn. Qed. - + (* Compatibility between inject and pow *) Lemma ZToField_pow : forall x n, @ZToField m x ^ n = ZToField (x ^ (Z.of_N n) mod m). @@ -317,7 +327,7 @@ End FandZ. Section RingModuloPre. Context {m:Z}. - Local Coercion ZToFm := ZToField : Z -> F m. Hint Unfold ZToFm. + Let ZToFm := ZToField : Z -> F m. Hint Unfold ZToFm. Local Coercion ZToFm : Z >-> F. (* Substitution to prove all Compats *) Ltac compat := repeat intro; subst; trivial. @@ -362,12 +372,12 @@ Section RingModuloPre. Proof. Fdefn; rewrite Z.mul_1_r; auto. Qed. - + Lemma F_mul_assoc: forall x y z : F m, x * (y * z) = x * y * z. Proof. Fdefn. - Qed. + Qed. Lemma F_pow_pow_N (x : F m) : forall (n : N), (x ^ id n)%F = pow_N 1%F mul x n. Proof. @@ -390,7 +400,7 @@ Section RingModuloPre. Qed. (***** Division Theory *****) - Definition Fquotrem(a b: F m): F m * F m := + Definition Fquotrem(a b: F m): F m * F m := let '(q, r) := (Z.quotrem a b) in (q : F m, r : F m). Lemma Fdiv_theory : div_theory eq (@add m) (@mul m) (@id _) Fquotrem. Proof. @@ -434,7 +444,7 @@ Section RingModuloPre. Qed. (* Redefine our division theory under the ring morphism *) - Lemma Fmorph_div_theory: + Lemma Fmorph_div_theory: div_theory eq Zplus Zmult (@ZToField m) Z.quotrem. Proof. constructor; intros; intuition. @@ -451,7 +461,7 @@ Section RingModuloPre. Fdefn. Qed. End RingModuloPre. - + Ltac Fconstant t := match t with @ZToField _ ?x => x | _ => NotConstant end. Ltac Fexp_tac t := Ncst t. Ltac Fpreprocess := rewrite <-?ZToField_0, ?ZToField_1. @@ -470,49 +480,49 @@ Module RingModulo (Export M : Modulus). Definition ring_morph_modulo := @Fring_morph modulus. Definition morph_div_theory_modulo := @Fmorph_div_theory modulus. Definition power_theory_modulo := @Fpower_theory modulus. - + Add Ring GFring_Z : ring_theory_modulo (morphism ring_morph_modulo, constants [Fconstant], div morph_div_theory_modulo, - power_tac power_theory_modulo [Fexp_tac]). + power_tac power_theory_modulo [Fexp_tac]). End RingModulo. Section VariousModulo. Context {m:Z}. - + Add Ring GFring_Z : (@Fring_theory m) (morphism (@Fring_morph m), constants [Fconstant], div (@Fmorph_div_theory m), - power_tac (@Fpower_theory m) [Fexp_tac]). + power_tac (@Fpower_theory m) [Fexp_tac]). Lemma F_mul_0_l : forall x : F m, 0 * x = 0. Proof. intros; ring. Qed. - + Lemma F_mul_0_r : forall x : F m, x * 0 = 0. Proof. intros; ring. Qed. - + Lemma F_mul_nonzero_l : forall a b : F m, a*b <> 0 -> a <> 0. intros; intuition; subst. assert (0 * b = 0) by ring; intuition. Qed. - + Lemma F_mul_nonzero_r : forall a b : F m, a*b <> 0 -> b <> 0. intros; intuition; subst. assert (a * 0 = 0) by ring; intuition. Qed. - + Lemma F_pow_distr_mul : forall (x y:F m) z, (0 <= z)%N -> (x ^ z) * (y ^ z) = (x * y) ^ z. Proof. intros. replace z with (Z.to_N (Z.of_N z)) by apply N2Z.id. - apply natlike_ind with (x := Z.of_N z); simpl; [ ring | | + apply natlike_ind with (x := Z.of_N z); simpl; [ ring | | replace 0%Z with (Z.of_N 0%N) by auto; apply N2Z.inj_le; auto]. intros z' z'_nonneg IHz'. rewrite Z2N.inj_succ by auto. @@ -521,7 +531,7 @@ Section VariousModulo. rewrite <- IHz'. ring. Qed. - + Lemma F_opp_0 : opp (0 : F m) = 0%F. Proof. intros; ring. @@ -563,7 +573,7 @@ Section VariousModulo. Proof. intros; ring. Qed. - + Lemma F_add_reg_r : forall x y z : F m, y + x = z + x -> y = z. Proof. intros ? ? ? A. @@ -653,7 +663,7 @@ Section VariousModulo. Proof. split; intro A; [ replace w with (w - x + x) by ring - | replace w with (w + z - z) by ring ]; rewrite A; ring. + | replace w with (w + z - z) by ring ]; rewrite A; ring. Qed. Definition isSquare (x : F m) := exists sqrt_x, sqrt_x ^ 2 = x. diff --git a/src/ModularArithmetic/ModularBaseSystem.v b/src/ModularArithmetic/ModularBaseSystem.v index 558b9a5a2..ca8c19d18 100644 --- a/src/ModularArithmetic/ModularBaseSystem.v +++ b/src/ModularArithmetic/ModularBaseSystem.v @@ -11,14 +11,14 @@ Local Open Scope Z_scope. Section PseudoMersenneBase. Context `{prm :PseudoMersenneBaseParams}. - + Definition decode (us : digits) : F modulus := ZToField (BaseSystem.decode base us). - - Definition rep (us : digits) (x : F modulus) := (length us <= length base)%nat /\ decode us = x. + + Definition rep (us : digits) (x : F modulus) := (length us = length base)%nat /\ decode us = x. Local Notation "u '~=' x" := (rep u x) (at level 70). Local Hint Unfold rep. - Definition encode (x : F modulus) := encode x. + Definition encode (x : F modulus) := encode x ++ BaseSystem.zeros (length base - 1)%nat. (* Converts from length of extended base to length of base by reduction modulo M.*) Definition reduce (us : digits) : digits := @@ -35,13 +35,13 @@ Section PseudoMersenneBase. End PseudoMersenneBase. Section CarryBasePow2. - Context `{prm :PseudoMersenneBaseParams}. + Context `{prm :PseudoMersenneBaseParams}. Definition log_cap i := nth_default 0 limb_widths i. Definition add_to_nth n (x:Z) xs := set_nth n (x + nth_default 0 xs n) xs. - + Definition pow2_mod n i := Z.land n (Z.ones i). Definition carry_simple i := fun us => @@ -54,64 +54,68 @@ Section CarryBasePow2. let us' := set_nth i (pow2_mod di (log_cap i)) us in add_to_nth 0 (c * (Z.shiftr di (log_cap i))) us'. - Definition carry i : digits -> digits := + Definition carry i : digits -> digits := if eq_nat_dec i (pred (length base)) then carry_and_reduce i else carry_simple i. Definition carry_sequence is us := fold_right carry us is. -End CarryBasePow2. - -Section Canonicalization. - Context `{prm :PseudoMersenneBaseParams}. - Fixpoint make_chain i := match i with | O => nil | S i' => i' :: make_chain i' end. - (* compute at compile time *) Definition full_carry_chain := make_chain (length limb_widths). - (* compute at compile time *) - Definition max_ones := Z.ones - ((fix loop current_max lw := - match lw with - | nil => current_max - | w :: lw' => loop (Z.max w current_max) lw' - end - ) 0 limb_widths). - - (* compute at compile time? *) Definition carry_full := carry_sequence full_carry_chain. + Definition carry_mul us vs := carry_full (mul us vs). + +End CarryBasePow2. + +Section Canonicalization. + Context `{prm :PseudoMersenneBaseParams}. + + (* compute at compile time *) + Definition max_ones := Z.ones (fold_right Z.max 0 limb_widths). + Definition max_bound i := Z.ones (log_cap i). - Definition isFull us := - (fix loop full i := - match i with - | O => full (* don't test 0; the test for 0 is the initial value of [full]. *) - | S i' => loop (andb (Z.eqb (max_bound i) (nth_default 0 us i)) full) i' - end - ) (Z.ltb (max_bound 0 - (c + 1)) (nth_default 0 us 0)) (length us - 1)%nat. + Fixpoint isFull' us full i := + match i with + | O => andb (Z.ltb (max_bound 0 - c) (nth_default 0 us 0)) full + | S i' => isFull' us (andb (Z.eqb (max_bound i) (nth_default 0 us i)) full) i' + end. + + Definition isFull us := isFull' us true (length base - 1)%nat. - Fixpoint range' n m := - match m with - | O => nil - | S m' => (n - m)%nat :: range' n m' + Fixpoint modulus_digits' i := + match i with + | O => max_bound i - c + 1 :: nil + | S i' => modulus_digits' i' ++ max_bound i :: nil end. - Definition range n := range' n n. + (* compute at compile time *) + Definition modulus_digits := modulus_digits' (length base - 1). + + Fixpoint map2 {A B C} (f : A -> B -> C) (la : list A) (lb : list B) : list C := + match la with + | nil => nil + | a :: la' => match lb with + | nil => nil + | b :: lb' => f a b :: map2 f la' lb' + end + end. + + Definition and_term us := if isFull us then max_ones else 0. - Definition land_max_bound and_term i := Z.land and_term (max_bound i). - Definition freeze us := let us' := carry_full (carry_full (carry_full us)) in - let and_term := if isFull us' then max_ones else 0 in + let and_term := and_term us' in (* [and_term] is all ones if us' is full, so the subtractions subtract q overall. Otherwise, it's all zeroes, and the subtractions do nothing. *) - map (fun x => (snd x) - land_max_bound and_term (fst x)) (combine (range (length us')) us'). - + map2 (fun x y => x - y) us' (map (Z.land and_term) modulus_digits). + End Canonicalization. diff --git a/src/ModularArithmetic/ModularBaseSystemOpt.v b/src/ModularArithmetic/ModularBaseSystemOpt.v index 981680b4a..116fe10e5 100644 --- a/src/ModularArithmetic/ModularBaseSystemOpt.v +++ b/src/ModularArithmetic/ModularBaseSystemOpt.v @@ -27,7 +27,12 @@ Definition Z_shiftl_by_opt := Eval compute in Z_shiftl_by. Definition nth_default_opt {A} := Eval compute in @nth_default A. Definition set_nth_opt {A} := Eval compute in @set_nth A. Definition map_opt {A B} := Eval compute in @map A B. -Definition base_from_limb_widths_opt := Eval compute in base_from_limb_widths. +Definition full_carry_chain_opt := Eval compute in @full_carry_chain. +Definition length_opt := Eval compute in length. +Definition base_opt := Eval compute in @base. +Definition max_ones_opt := Eval compute in @max_ones. +Definition max_bound_opt := Eval compute in @max_bound. +Definition minus_opt := Eval compute in minus. Definition Let_In {A P} (x : A) (f : forall y : A, P y) := let y := x in f y. @@ -71,18 +76,22 @@ Ltac construct_params prime_modulus len k := | abstract apply prime_modulus | abstract brute_force_indices lw]. -Definition construct_mul2modulus {m} (prm : PseudoMersenneBaseParams m) : digits := +Definition construct_mul2modulus {m} (prm : PseudoMersenneBaseParams m) : digits := match limb_widths with | nil => nil | x :: tail => 2 ^ (x + 1) - (2 * c) :: map (fun w => 2 ^ (w + 1) - 2) tail end. +Ltac compute_preconditions := + cbv; intros; repeat match goal with H : _ \/ _ |- _ => + destruct H; subst; [ congruence | ] end; (congruence || omega). + Ltac subst_precondition := match goal with | [H : ?P, H' : ?P -> _ |- _] => specialize (H' H); clear H end. -Ltac kill_precondition H := +Ltac kill_precondition H := forward H; [abstract (try exact eq_refl; clear; cbv; intros; repeat break_or_hyp; intuition)|]; subst_precondition. @@ -95,8 +104,7 @@ Ltac compute_formula := let p := fresh "p" in set (p := P) in H at 1; change P with p at 1; let r := fresh "r" in set (r := result) in H |- *; cbv -[m p r PseudoMersenneBaseRep.rep] in H; - repeat rewrite ?Z.mul_1_r, ?Z.add_0_l, ?Z.add_assoc, ?Z.mul_assoc in H; - exact H + repeat rewrite ?Z.mul_1_r, ?Z.add_0_l, ?Z.add_assoc, ?Z.mul_assoc in H end. Section Carries. @@ -113,8 +121,9 @@ Section Carries. rewrite <- pull_app_if_sumbool. cbv beta delta [carry carry_and_reduce carry_simple add_to_nth log_cap - pow2_mod Z.ones Z.pred base + pow2_mod Z.ones Z.pred PseudoMersenneBaseParams.limb_widths]. + change @base with @base_opt. change @nth_default with @nth_default_opt in *. change @set_nth with @set_nth_opt in *. lazymatch goal with @@ -129,7 +138,6 @@ Section Carries. change @set_nth with @set_nth_opt. change @map with @map_opt. rewrite <- @beq_nat_eq_nat_dec. - change base_from_limb_widths with base_from_limb_widths_opt. reflexivity. Defined. @@ -179,7 +187,7 @@ Section Carries. change (LHS = Let_In (nth_default_opt 0%Z b i) RHSf). change Z.shiftl with Z_shiftl_opt. change (-1) with (Z_opp_opt 1). - change Z.add with Z_add_opt at 8 12 20 24. + change Z.add with Z_add_opt at 5 9 17 21. reflexivity. Defined. @@ -191,6 +199,39 @@ Section Carries. @carry_opt_cps T i f b = f (carry i b) := proj2_sig (carry_opt_cps_sig i f b). + Definition carry_sequence_opt_cps2_sig {T} (is : list nat) (us : digits) + (f : digits -> T) + : { b : T | (forall i, In i is -> i < length base)%nat -> b = f (carry_sequence is us) }. + Proof. + eexists. + cbv [carry_sequence]. + transitivity (fold_right carry_opt_cps f (List.rev is) us). + Focus 2. + { + assert (forall i, In i (rev is) -> i < length base)%nat as Hr. { + subst. intros. rewrite <- in_rev in *. auto. } + remember (rev is) as ris eqn:Heq. + rewrite <- (rev_involutive is), <- Heq. + clear H Heq is. + rewrite fold_left_rev_right. + revert us; induction ris; [ reflexivity | ]; intros. + { simpl. + rewrite <- IHris; clear IHris; [|intros; apply Hr; right; assumption]. + rewrite carry_opt_cps_correct; [reflexivity|]. + apply Hr; left; reflexivity. + } } + Unfocus. + reflexivity. + Defined. + + Definition carry_sequence_opt_cps2 {T} is us (f : digits -> T) := + Eval cbv [proj1_sig carry_sequence_opt_cps2_sig] in + proj1_sig (carry_sequence_opt_cps2_sig is us f). + + Definition carry_sequence_opt_cps2_correct {T} is us (f : digits -> T) + : (forall i, In i is -> i < length base)%nat -> carry_sequence_opt_cps2 is us f = f (carry_sequence is us) + := proj2_sig (carry_sequence_opt_cps2_sig is us f). + Definition carry_sequence_opt_cps_sig (is : list nat) (us : digits) : { b : digits | (forall i, In i is -> i < length base)%nat -> b = carry_sequence is us }. Proof. @@ -198,7 +239,7 @@ Section Carries. cbv [carry_sequence]. transitivity (fold_right carry_opt_cps id (List.rev is) us). Focus 2. - { + { assert (forall i, In i (rev is) -> i < length base)%nat as Hr. { subst. intros. rewrite <- in_rev in *. auto. } remember (rev is) as ris eqn:Heq. @@ -226,14 +267,55 @@ Section Carries. Lemma carry_sequence_opt_cps_rep : forall (is : list nat) (us : list Z) (x : F modulus), (forall i : nat, In i is -> i < length base)%nat -> - length us = length base -> rep us x -> rep (carry_sequence_opt_cps is us) x. Proof. intros. rewrite carry_sequence_opt_cps_correct by assumption. - apply carry_sequence_rep; assumption. + apply carry_sequence_rep; eauto using rep_length. Qed. + Lemma full_carry_chain_bounds : forall i, In i full_carry_chain -> (i < length base)%nat. + Proof. + unfold full_carry_chain; rewrite <-base_length; intros. + apply make_chain_lt; auto. + Qed. + + Definition carry_full_opt_sig (us : digits) : { b : digits | b = carry_full us }. + Proof. + eexists. + cbv [carry_full]. + change @full_carry_chain with full_carry_chain_opt. + rewrite <-carry_sequence_opt_cps_correct by (auto; apply full_carry_chain_bounds). + reflexivity. + Defined. + + Definition carry_full_opt (us : digits) : digits + := Eval cbv [proj1_sig carry_full_opt_sig] in proj1_sig (carry_full_opt_sig us). + + Definition carry_full_opt_correct us : carry_full_opt us = carry_full us := + proj2_sig (carry_full_opt_sig us). + + Definition carry_full_opt_cps_sig + {T} + (f : digits -> T) + (us : digits) + : { d : T | d = f (carry_full us) }. + Proof. + eexists. + rewrite <- carry_full_opt_correct. + cbv beta iota delta [carry_full_opt]. + rewrite carry_sequence_opt_cps_correct by apply full_carry_chain_bounds. + rewrite <-carry_sequence_opt_cps2_correct by apply full_carry_chain_bounds. + reflexivity. + Defined. + + Definition carry_full_opt_cps {T} (f : digits -> T) (us : digits) : T + := Eval cbv [proj1_sig carry_full_opt_cps_sig] in proj1_sig (carry_full_opt_cps_sig f us). + + Definition carry_full_opt_cps_correct {T} us (f : digits -> T) : + carry_full_opt_cps f us = f (carry_full us) := + proj2_sig (carry_full_opt_cps_sig f us). + End Carries. Section Addition. @@ -416,12 +498,11 @@ Section Multiplication. eexists. cbv [BaseSystem.mul mul mul_each mul_bi mul_bi' zeros ext_base reduce]. rewrite <- mul'_opt_correct. - cbv [base PseudoMersenneBaseParams.limb_widths]. + change @base with base_opt. rewrite map_shiftl by apply k_nonneg. rewrite c_subst. rewrite k_subst. change @map with @map_opt. - change base_from_limb_widths with base_from_limb_widths_opt. change @Z_shiftl_by with @Z_shiftl_by_opt. reflexivity. Defined. @@ -433,31 +514,158 @@ Section Multiplication. : mul_opt us vs = mul us vs := proj2_sig (mul_opt_sig us vs). - Lemma mul_opt_rep: + Definition carry_mul_opt_sig (us vs : T) : { b : digits | b = carry_mul us vs }. + Proof. + eexists. + cbv [carry_mul]. + erewrite <-carry_full_opt_correct by eauto. + erewrite <-mul_opt_correct. + reflexivity. + Defined. + + Definition carry_mul_opt (us vs : T) : digits + := Eval cbv [proj1_sig carry_mul_opt_sig] in proj1_sig (carry_mul_opt_sig us vs). + + Definition carry_mul_opt_correct us vs + : carry_mul_opt us vs = carry_mul us vs + := proj2_sig (carry_mul_opt_sig us vs). + + Lemma carry_mul_opt_rep: forall (u v : T) (x y : F modulus), PseudoMersenneBaseRep.rep u x -> PseudoMersenneBaseRep.rep v y -> - PseudoMersenneBaseRep.rep (mul_opt u v) (x * y)%F. + PseudoMersenneBaseRep.rep (carry_mul_opt u v) (x * y)%F. Proof. intros. - rewrite mul_opt_correct. - change mul with PseudoMersenneBaseRep.mul. + rewrite carry_mul_opt_correct. + change carry_mul with PseudoMersenneBaseRep.mul. auto using PseudoMersenneBaseRep.mul_rep. Qed. - Definition carry_mul_opt - (is : list nat) - (us vs : list Z) - : list Z - := carry_sequence_opt_cps c_ is (mul_opt us vs). - - Lemma carry_mul_opt_correct - : forall (is : list nat) (us vs : list Z) (x y: F modulus), - PseudoMersenneBaseRep.rep us x -> PseudoMersenneBaseRep.rep vs y -> - (forall i : nat, In i is -> i < length base)%nat -> - length (mul_opt us vs) = length base -> - PseudoMersenneBaseRep.rep (carry_mul_opt is us vs) (x*y)%F. +End Multiplication. + +Record freezePreconditions {modulus} (prm : PseudoMersenneBaseParams modulus) int_width := +mkFreezePreconditions { + lt_1_length_base : (1 < length base)%nat; + int_width_pos : 0 < int_width; + int_width_compat : forall w, In w limb_widths -> w <= int_width; + c_pos : 0 < c; + c_reduce1 : c * (Z.ones (int_width - log_cap (pred (length base)))) < max_bound 0 + 1; + c_reduce2 : c <= max_bound 0 - c; + two_pow_k_le_2modulus : 2 ^ k <= 2 * modulus +}. +Local Hint Resolve lt_1_length_base int_width_pos int_width_compat c_pos + c_reduce1 c_reduce2 two_pow_k_le_2modulus. + +Section Canonicalization. + Context `{prm : PseudoMersenneBaseParams} {sc : SubtractionCoefficient modulus prm} + (* allows caller to precompute k and c *) + (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_) + {int_width} (preconditions : freezePreconditions prm int_width). + + Definition modulus_digits_opt_sig : + { b : digits | b = modulus_digits }. + Proof. + eexists. + cbv beta iota delta [modulus_digits modulus_digits' app]. + change @max_bound with max_bound_opt. + rewrite c_subst. + change length with length_opt. + change minus with minus_opt. + change Z.add with Z_add_opt. + change Z.sub with Z_sub_opt. + change @base with base_opt. + reflexivity. + Defined. + + Definition modulus_digits_opt : digits + := Eval cbv [proj1_sig modulus_digits_opt_sig] in proj1_sig (modulus_digits_opt_sig). + + Definition modulus_digits_opt_correct + : modulus_digits_opt = modulus_digits + := proj2_sig (modulus_digits_opt_sig). + + + Definition carry_full_3_opt_cps_sig + {T} (f : digits -> T) + (us : digits) + : { d : T | d = f (carry_full (carry_full (carry_full us))) }. + Proof. + eexists. + transitivity (carry_full_opt_cps c_ (carry_full_opt_cps c_ (carry_full_opt_cps c_ f)) us). + Focus 2. { + rewrite !carry_full_opt_cps_correct by assumption; reflexivity. + } + Unfocus. + reflexivity. + Defined. + + Definition carry_full_3_opt_cps {T} (f : digits -> T) (us : digits) : T + := Eval cbv [proj1_sig carry_full_3_opt_cps_sig] in proj1_sig (carry_full_3_opt_cps_sig f us). + + Definition carry_full_3_opt_cps_correct {T} (f : digits -> T) us : + carry_full_3_opt_cps f us = f (carry_full (carry_full (carry_full us))) := + proj2_sig (carry_full_3_opt_cps_sig f us). + + Definition freeze_opt_sig (us : T) : + { b : digits | b = freeze us }. Proof. - intros is us vs x y; intros. - change (carry_mul_opt _ _ _) with (carry_sequence_opt_cps c_ is (mul_opt us vs)). - apply carry_sequence_opt_cps_rep, mul_opt_rep; auto. + eexists. + cbv [freeze]. + cbv [and_term]. + let LHS := match goal with |- ?LHS = ?RHS => LHS end in + let RHS := match goal with |- ?LHS = ?RHS => RHS end in + let RHSf := match (eval pattern (isFull (carry_full (carry_full (carry_full us)))) in RHS) with ?RHSf _ => RHSf end in + change (LHS = Let_In (isFull(carry_full (carry_full (carry_full us)))) RHSf). + let LHS := match goal with |- ?LHS = ?RHS => LHS end in + let RHS := match goal with |- ?LHS = ?RHS => RHS end in + let RHSf := match (eval pattern (carry_full (carry_full (carry_full us))) in RHS) with ?RHSf _ => RHSf end in + rewrite <-carry_full_3_opt_cps_correct with (f := RHSf). + cbv beta iota delta [and_term isFull isFull']. + change length with length_opt. + change @max_bound with max_bound_opt. + rewrite c_subst. + change @max_ones with max_ones_opt. + change @base with base_opt. + change minus with minus_opt. + change @map with @map_opt. + change Z.sub with Z_sub_opt at 1. + rewrite <-modulus_digits_opt_correct. + reflexivity. + Defined. + + Definition freeze_opt (us : T) : digits + := Eval cbv beta iota delta [proj1_sig freeze_opt_sig] in proj1_sig (freeze_opt_sig us). + + Definition freeze_opt_correct us + : freeze_opt us = freeze us + := proj2_sig (freeze_opt_sig us). + + Lemma freeze_opt_canonical: forall us vs x, + @pre_carry_bounds _ _ int_width us -> PseudoMersenneBaseRep.rep us x -> + @pre_carry_bounds _ _ int_width vs -> PseudoMersenneBaseRep.rep vs x -> + freeze_opt us = freeze_opt vs. + Proof. + intros. + rewrite !freeze_opt_correct. + change PseudoMersenneBaseRep.rep with rep in *. + eapply freeze_canonical with (B := int_width); eauto. Qed. -End Multiplication.
\ No newline at end of file + + Lemma freeze_opt_preserves_rep : forall us x, PseudoMersenneBaseRep.rep us x -> + PseudoMersenneBaseRep.rep (freeze_opt us) x. + Proof. + intros. + rewrite freeze_opt_correct. + change PseudoMersenneBaseRep.rep with rep in *. + eapply freeze_preserves_rep; eauto. + Qed. + + Lemma freeze_opt_spec : forall us vs x, rep us x -> rep vs x -> + @pre_carry_bounds _ _ int_width us -> + @pre_carry_bounds _ _ int_width vs -> + (PseudoMersenneBaseRep.rep (freeze_opt us) x /\ freeze_opt us = freeze_opt vs). + Proof. + split; eauto using freeze_opt_canonical. + auto using freeze_opt_preserves_rep. + Qed. + +End Canonicalization.
\ No newline at end of file diff --git a/src/ModularArithmetic/ModularBaseSystemProofs.v b/src/ModularArithmetic/ModularBaseSystemProofs.v index 274acff5a..0462b0f37 100644 --- a/src/ModularArithmetic/ModularBaseSystemProofs.v +++ b/src/ModularArithmetic/ModularBaseSystemProofs.v @@ -1,7 +1,7 @@ Require Import Zpower ZArith. Require Import Coq.Numbers.Natural.Peano.NPeano. Require Import List. -Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil. +Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil Crypto.Util.NatUtil. Require Import VerdiTactics. Require Crypto.BaseSystem. Require Import Crypto.ModularArithmetic.ModularBaseSystem Crypto.ModularArithmetic.PrimeFieldTheorems. @@ -22,14 +22,21 @@ Section PseudoMersenneProofs. autounfold; intuition. Qed. + Lemma rep_length : forall us x, us ~= x -> length us = length base. + Proof. + autounfold; intuition. + Qed. + Lemma encode_rep : forall x : F modulus, encode x ~= x. Proof. intros. unfold encode, rep. split. { unfold encode; simpl. - apply base_length_nonzero. + rewrite length_zeros. + pose proof base_length_nonzero; omega. } { unfold decode. + rewrite decode_highzeros. rewrite encode_rep. apply ZToField_FieldToZ. apply bv. @@ -40,8 +47,7 @@ Section PseudoMersenneProofs. Proof. autounfold; intuition. { unfold add. - rewrite add_length_le_max. - case_max; try rewrite Max.max_r; omega. + auto using add_same_length. } unfold decode in *; unfold decode in *. rewrite add_rep. @@ -49,15 +55,14 @@ Section PseudoMersenneProofs. subst; auto. Qed. - Lemma sub_rep : forall c c_0modq, (length c <= length base)%nat -> - forall u v x y, u ~= x -> v ~= y -> + Lemma sub_rep : forall c c_0modq, (length c = length base)%nat -> + forall u v x y, u ~= x -> v ~= y -> ModularBaseSystem.sub c c_0modq u v ~= (x-y)%F. Proof. autounfold; unfold ModularBaseSystem.sub; intuition. { - rewrite sub_length_le_max. + rewrite sub_length. case_max; try rewrite Max.max_r; try omega. - rewrite add_length_le_max. - case_max; try rewrite Max.max_r; omega. + auto using add_same_length. } unfold decode in *; unfold BaseSystem.decode in *. rewrite BaseSystemProofs.sub_rep, BaseSystemProofs.add_rep. @@ -66,7 +71,7 @@ Section PseudoMersenneProofs. subst; auto. Qed. - Lemma decode_short : forall (us : BaseSystem.digits), + Lemma decode_short : forall (us : BaseSystem.digits), (length us <= length base)%nat -> BaseSystem.decode base us = BaseSystem.decode ext_base us. Proof. @@ -80,11 +85,11 @@ Section PseudoMersenneProofs. Qed. Lemma mul_rep_extended : forall (us vs : BaseSystem.digits), - (length us <= length base)%nat -> + (length us <= length base)%nat -> (length vs <= length base)%nat -> (BaseSystem.decode base us) * (BaseSystem.decode base vs) = BaseSystem.decode ext_base (BaseSystem.mul ext_base us vs). Proof. - intros. + intros. rewrite mul_rep by (apply ExtBaseVector || unfold ext_base; simpl_list; omega). f_equal; rewrite decode_short; auto. Qed. @@ -93,7 +98,7 @@ Section PseudoMersenneProofs. pose proof (Znumtheory.prime_ge_2 _ prime_modulus); omega. Qed. - (* a = r + s(2^k) = r + s(2^k - c + c) = r + s(2^k - c) + cs = r + cs *) + (* a = r + s(2^k) = r + s(2^k - c + c) = r + s(2^k - c) + cs = r + cs *) Lemma pseudomersenne_add: forall x y, (x + ((2^k) * y)) mod modulus = (x + (c * y)) mod modulus. Proof. intros. @@ -137,34 +142,16 @@ Section PseudoMersenneProofs. rewrite mul_each_rep; auto. Qed. - Lemma reduce_length : forall us, - (length us <= length ext_base)%nat -> - (length (reduce us) <= length base)%nat. + Lemma reduce_length : forall us, + (length base <= length us <= length ext_base)%nat -> + (length (reduce us) = length base)%nat. Proof. - intros. - unfold reduce. - remember (map (Z.mul c) (skipn (length base) us)) as high. - remember (firstn (length base) us) as low. - assert (length low >= length high)%nat. { - subst. rewrite firstn_length. - rewrite map_length. - rewrite skipn_length. - destruct (le_dec (length base) (length us)). { - rewrite Min.min_l by omega. - rewrite extended_base_length in H. omega. - } { - rewrite Min.min_r; omega. - } - } - assert ((length low <= length base)%nat) - by (rewrite Heqlow; rewrite firstn_length; apply Min.le_min_l). - assert (length high <= length base)%nat - by (rewrite Heqhigh; rewrite map_length; rewrite skipn_length; - rewrite extended_base_length in H; omega). - rewrite add_trailing_zeros; auto. - rewrite (add_same_length _ _ (length low)); auto. - rewrite app_length. - rewrite length_zeros; intuition. + rewrite extended_base_length. + unfold reduce; intros. + rewrite add_length_exact. + rewrite map_length, firstn_length, skipn_length. + rewrite Min.min_l by omega. + apply Max.max_l; omega. Qed. Lemma mul_rep : forall u v x y, u ~= x -> v ~= y -> u .* v ~= (x*y)%F. @@ -172,20 +159,22 @@ Section PseudoMersenneProofs. autounfold; unfold ModularBaseSystem.mul; intuition. { apply reduce_length. - rewrite mul_length, extended_base_length. - omega. + rewrite mul_length_exact, extended_base_length; try omega. + destruct u; try congruence. + rewrite @nil_length0 in *. + pose proof base_length_nonzero; omega. } { rewrite ZToField_mod, reduce_rep, <-ZToField_mod. rewrite mul_rep by (apply ExtBaseVector || rewrite extended_base_length; omega). subst. - do 2 rewrite decode_short by auto. + do 2 rewrite decode_short by omega. apply ZToField_mul. } Qed. Lemma set_nth_sum : forall n x us, (n < length us)%nat -> - BaseSystem.decode base (set_nth n x us) = + BaseSystem.decode base (set_nth n x us) = (x - nth_default 0 us n) * nth_default 0 base n + BaseSystem.decode base us. Proof. intros. @@ -213,12 +202,27 @@ Section PseudoMersenneProofs. Qed. Lemma add_to_nth_sum : forall n x us, (n < length us)%nat -> - BaseSystem.decode base (add_to_nth n x us) = + BaseSystem.decode base (add_to_nth n x us) = x * nth_default 0 base n + BaseSystem.decode base us. Proof. unfold add_to_nth; intros; rewrite set_nth_sum; try ring_simplify; auto. Qed. + Lemma add_to_nth_nth_default : forall n x l i, (0 <= i < length l)%nat -> + nth_default 0 (add_to_nth n x l) i = + if (eq_nat_dec i n) then x + nth_default 0 l i else nth_default 0 l i. + Proof. + intros. + unfold add_to_nth. + rewrite set_nth_nth_default by assumption. + break_if; subst; reflexivity. + Qed. + + Lemma length_add_to_nth : forall n x l, length (add_to_nth n x l) = length l. + Proof. + unfold add_to_nth; intros; apply length_set_nth. + Qed. + Lemma nth_default_base_positive : forall i, (i < length base)%nat -> nth_default 0 base i > 0. Proof. @@ -240,13 +244,21 @@ Section PseudoMersenneProofs. apply base_succ; auto. Qed. + Lemma Fdecode_decode_mod : forall us x, (length us = length base) -> + decode us = x -> BaseSystem.decode base us mod modulus = x. + Proof. + unfold decode; intros ? ? ? decode_us. + rewrite <-decode_us. + apply FieldToZ_ZToField. + Qed. + End PseudoMersenneProofs. Section CarryProofs. Context `{prm : PseudoMersenneBaseParams}. Local Notation "u '~=' x" := (rep u x) (at level 70). Hint Unfold log_cap. - + Lemma base_length_lt_pred : (pred (length base) < length base)%nat. Proof. pose proof base_length_nonzero; omega. @@ -260,7 +272,7 @@ Section CarryProofs. apply limb_widths_nonneg. eapply nth_error_value_In; eauto. Qed. - + Lemma nth_default_base_succ : forall i, (S i < length base)%nat -> nth_default 0 base (S i) = 2 ^ log_cap i * nth_default 0 base i. Proof. @@ -342,8 +354,8 @@ Section CarryProofs. Qed. Lemma carry_length : forall i us, - (length us <= length base)%nat -> - (length (carry i us) <= length base)%nat. + (length us = length base)%nat -> + (length (carry i us) = length base)%nat. Proof. unfold carry, carry_simple, carry_and_reduce, add_to_nth. intros; break_if; subst; repeat (rewrite length_set_nth); auto. @@ -356,36 +368,19 @@ Section CarryProofs. us ~= x -> carry i us ~= x. Proof. pose carry_length. pose carry_decode_eq_reduce. pose carry_simple_decode_eq. - unfold rep, decode, carry in *; intros. - intuition; break_if; subst; eauto; - apply F_eq; simpl; intuition. + intros; split; auto. + unfold rep, decode, carry in *. + intuition; break_if; subst; eauto; apply F_eq; simpl; intuition. Qed. Hint Resolve carry_rep. Lemma carry_sequence_length: forall is us, - (length us <= length base)%nat -> - (length (carry_sequence is us) <= length base)%nat. - Proof. - induction is; boring. - Qed. - Hint Resolve carry_sequence_length. - - Lemma carry_length_exact : forall i us, - (length us = length base)%nat -> - (length (carry i us) = length base)%nat. - Proof. - unfold carry, carry_simple, carry_and_reduce, add_to_nth. - intros; break_if; subst; repeat (rewrite length_set_nth); auto. - Qed. - - Lemma carry_sequence_length_exact: forall is us, (length us = length base)%nat -> (length (carry_sequence is us) = length base)%nat. Proof. induction is; boring. - apply carry_length_exact; auto. Qed. - Hint Resolve carry_sequence_length_exact. + Hint Resolve carry_sequence_length. Lemma carry_sequence_rep : forall is us x, (forall i, In i is -> (i < length base)%nat) -> @@ -395,46 +390,45 @@ Section CarryProofs. induction is; boring. Qed. -End CarryProofs. -Section CanonicalizationProofs. - Context `{prm : PseudoMersenneBaseParams} (lt_1_length_base : (1 < length base)%nat) (c_pos : 0 < c) {B} (B_pos : 0 < B) (B_compat : forall w, In w limb_widths -> w <= B). - - (* TODO : move *) - Lemma set_nth_nth_default : forall {A} (d:A) n x l i, (0 <= i < length l)%nat -> - nth_default d (set_nth n x l) i = - if (eq_nat_dec i n) then x else nth_default d l i. + (* TODO : move? *) + Lemma make_chain_lt : forall x i : nat, In i (make_chain x) -> (i < x)%nat. Proof. - induction n; (destruct l; [intros; simpl in *; omega | ]); simpl; - destruct i; break_if; try omega; intros; try apply nth_default_cons; - rewrite !nth_default_cons_S, ?IHn; try break_if; omega || reflexivity. + induction x; simpl; intuition. Qed. - (* TODO : move *) - Lemma add_to_nth_nth_default : forall n x l i, (0 <= i < length l)%nat -> - nth_default 0 (add_to_nth n x l) i = - if (eq_nat_dec i n) then x + nth_default 0 l i else nth_default 0 l i. + Lemma carry_full_preserves_rep : forall us x, + rep us x -> rep (carry_full us) x. Proof. - intros. - unfold add_to_nth. - rewrite set_nth_nth_default by assumption. - break_if; subst; reflexivity. + unfold carry_full; intros. + apply carry_sequence_rep; auto. + unfold full_carry_chain; rewrite base_length; apply make_chain_lt. + eauto using rep_length. Qed. - (* TODO : move *) - Lemma length_add_to_nth : forall n x l, length (add_to_nth n x l) = length l. - Proof. - unfold add_to_nth; intros; apply length_set_nth. - Qed. + Opaque carry_full. - (* TODO : move *) - Lemma singleton_list : forall {A} (l : list A), length l = 1%nat -> exists x, l = x :: nil. + Lemma carry_mul_rep : forall us vs x y, rep us x -> rep vs y -> + rep (carry_mul us vs) (x * y)%F. Proof. - intros; destruct l; simpl in *; try congruence. - eexists; f_equal. - apply length0_nil; omega. + unfold carry_mul; intros; apply carry_full_preserves_rep. + auto using mul_rep. Qed. +End CarryProofs. + +Section CanonicalizationProofs. + Context `{prm : PseudoMersenneBaseParams} (lt_1_length_base : (1 < length base)%nat) + {B} (B_pos : 0 < B) (B_compat : forall w, In w limb_widths -> w <= B) + (c_pos : 0 < c) + (* on the first reduce step, we add at most one bit of width to the first digit *) + (c_reduce1 : c * (Z.ones (B - log_cap (pred (length base)))) < max_bound 0 + 1) + (* on the second reduce step, we add at most one bit of width to the first digit, + and leave room to carry c one more time after the highest bit is carried *) + (c_reduce2 : c <= max_bound 0 - c) + (* this condition is probably implied by c_reduce2, but is more straighforward to compute than to prove *) + (two_pow_k_le_2modulus : 2 ^ k <= 2 * modulus). + (* BEGIN groundwork proofs *) Lemma pow_2_log_cap_pos : forall i, 0 < 2 ^ log_cap i. @@ -451,7 +445,7 @@ Section CanonicalizationProofs. omega. Qed. - Hint Resolve log_cap_nonneg. + Local Hint Resolve log_cap_nonneg. Lemma pow2_mod_log_cap_range : forall a i, 0 <= pow2_mod a (log_cap i) <= max_bound i. Proof. intros. @@ -488,6 +482,16 @@ Section CanonicalizationProofs. omega. Qed. + Lemma max_bound_pos : forall i, (i < length base)%nat -> 0 < max_bound i. + Proof. + unfold max_bound, log_cap; intros; apply Z_ones_pos_pos. + apply limb_widths_pos. + rewrite nth_default_eq. + apply nth_In. + rewrite <-base_length; assumption. + Qed. + Local Hint Resolve max_bound_pos. + Lemma max_bound_nonneg : forall i, 0 <= max_bound i. Proof. unfold max_bound; intros; auto using Z_ones_nonneg. @@ -501,15 +505,6 @@ Section CanonicalizationProofs. rewrite Z.land_ones; auto. Qed. - Lemma pow2_mod_upper_bound : forall a b, (0 <= a) -> (0 <= b) -> pow2_mod a b <= a. - Proof. - intros. - unfold pow2_mod. - rewrite Z.land_ones; auto. - apply Z.mod_le; auto. - apply Z.pow_pos_nonneg; omega. - Qed. - Lemma shiftr_eq_0_max_bound : forall i a, Z.shiftr a (log_cap i) = 0 -> a <= max_bound i. Proof. @@ -550,26 +545,26 @@ Section CanonicalizationProofs. omega. Qed. + Lemma log_cap_eq : forall i, log_cap i = nth_default 0 limb_widths i. + Proof. + reflexivity. + Qed. + (* END groundwork proofs *) Opaque pow2_mod log_cap max_bound. (* automation *) Ltac carry_length_conditions' := unfold carry_full, add_to_nth; - rewrite ?length_set_nth, ?carry_length_exact, ?carry_sequence_length_exact, ?carry_sequence_length_exact; + rewrite ?length_set_nth, ?carry_length, ?carry_sequence_length; try omega; try solve [pose proof base_length; pose proof base_length_nonzero; omega || auto ]. Ltac carry_length_conditions := try split; try omega; repeat carry_length_conditions'. - Ltac add_set_nth := rewrite ?add_to_nth_nth_default; try solve [carry_length_conditions]; - try break_if; try omega; rewrite ?set_nth_nth_default; try solve [carry_length_conditions]; - try break_if; try omega. + Ltac add_set_nth := + rewrite ?add_to_nth_nth_default by carry_length_conditions; break_if; try omega; + rewrite ?set_nth_nth_default by carry_length_conditions; break_if; try omega. (* BEGIN defs *) - Definition c_carry_constraint : Prop := - (c * (Z.ones (B - log_cap (pred (length base)))) < max_bound 0 + 1) - /\ (max_bound 0 + c < 2 ^ (log_cap 0 + 1)) - /\ (c <= max_bound 0 - c). - Definition pre_carry_bounds us := forall i, 0 <= nth_default 0 us i < if (eq_nat_dec i 0) then 2 ^ B else 2 ^ B - 2 ^ (B - log_cap (pred i)). @@ -581,26 +576,10 @@ Section CanonicalizationProofs. specialize (PCB i). omega. Qed. - Hint Resolve pre_carry_bounds_nonzero. + Local Hint Resolve pre_carry_bounds_nonzero. - Definition carry_done us := forall i, (i < length base)%nat -> Z.shiftr (nth_default 0 us i) (log_cap i) = 0. - - Lemma carry_carry_done_done : forall i us, - (length us = length base)%nat -> - (i < length base)%nat -> - (forall i, 0 <= nth_default 0 us i) -> - carry_done us -> carry_done (carry i us). - Proof. - unfold carry_done; intros until 3. intros Hcarry_done ? ?. - unfold carry, carry_simple, carry_and_reduce; break_if; subst. - + rewrite Hcarry_done by omega. - rewrite pow2_mod_log_cap_small by (intuition; auto using shiftr_eq_0_max_bound). - destruct i0; add_set_nth; rewrite ?Z.mul_0_r, ?Z.add_0_l; auto. - match goal with H : S _ = pred (length base) |- _ => rewrite H; auto end. - + rewrite Hcarry_done by omega. - rewrite pow2_mod_log_cap_small by (intuition; auto using shiftr_eq_0_max_bound). - destruct i0; add_set_nth; subst; rewrite ?Z.add_0_l; auto. - Qed. + Definition carry_done us := forall i, (i < length base)%nat -> + 0 <= nth_default 0 us i /\ Z.shiftr (nth_default 0 us i) (log_cap i) = 0. (* END defs *) @@ -620,6 +599,7 @@ Section CanonicalizationProofs. apply pow2_mod_log_cap_bounds_upper. - rewrite nth_default_out_of_bounds by carry_length_conditions; auto. Qed. + Local Hint Resolve nth_default_carry_bound_upper. Lemma nth_default_carry_bound_lower : forall i us, (length us = length base) -> 0 <= nth_default 0 (carry i us) i. @@ -635,6 +615,7 @@ Section CanonicalizationProofs. apply pow2_mod_log_cap_bounds_lower. - rewrite nth_default_out_of_bounds by carry_length_conditions; omega. Qed. + Local Hint Resolve nth_default_carry_bound_lower. Lemma nth_default_carry_bound_succ_lower : forall i us, (forall i, 0 <= nth_default 0 us i) -> (length us = length base) -> @@ -645,18 +626,15 @@ Section CanonicalizationProofs. + subst. replace (S (pred (length base))) with (length base) by omega. rewrite nth_default_out_of_bounds; carry_length_conditions. unfold carry_and_reduce. - add_set_nth. + carry_length_conditions. + unfold carry_simple. destruct (lt_dec (S i) (length us)). - - add_set_nth. - apply Z.add_nonneg_nonneg; [ apply Z.shiftr_nonneg | ]; unfold pre_carry_bounds in PCB. - * specialize (PCB i). omega. - * specialize (PCB (S i)). omega. + - add_set_nth; zero_bounds. - rewrite nth_default_out_of_bounds by carry_length_conditions; omega. Qed. Lemma carry_unaffected_low : forall i j us, ((0 < i < j)%nat \/ (i = 0 /\ j <> 0 /\ j <> pred (length base))%nat)-> - (length us = length base) -> + (length us = length base) -> nth_default 0 (carry j us) i = nth_default 0 us i. Proof. intros. @@ -671,7 +649,7 @@ Section CanonicalizationProofs. (omega || rewrite length_add_to_nth; rewrite length_set_nth; pose proof base_length_nonzero; omega). reflexivity. Qed. - + Lemma carry_unaffected_high : forall i j us, (S j < i)%nat -> (length us = length base) -> nth_default 0 (carry j us) i = nth_default 0 us i. Proof. @@ -679,7 +657,7 @@ Section CanonicalizationProofs. destruct (lt_dec i (length us)); [ | rewrite !nth_default_out_of_bounds by carry_length_conditions; reflexivity]. unfold carry, carry_simple. - break_if; add_set_nth. + break_if; [omega | add_set_nth]. Qed. Lemma carry_nothing : forall i j us, (i < length base)%nat -> @@ -688,23 +666,65 @@ Section CanonicalizationProofs. nth_default 0 (carry j us) i = nth_default 0 us i. Proof. unfold carry, carry_simple, carry_and_reduce; intros. - break_if; (add_set_nth; + break_if; (add_set_nth; [ rewrite max_bound_shiftr_eq_0 by omega; ring | subst; apply pow2_mod_log_cap_small; assumption ]). Qed. + Lemma carry_done_bounds : forall us, (length us = length base) -> + (carry_done us <-> forall i, 0 <= nth_default 0 us i < 2 ^ log_cap i). + Proof. + intros ? ?; unfold carry_done; split; [ intros Hcarry_done i | intros Hbounds i i_lt ]. + + destruct (lt_dec i (length base)) as [i_lt | i_nlt]. + - specialize (Hcarry_done i i_lt). + split; [ intuition | ]. + rewrite <- max_bound_log_cap. + apply Z.lt_succ_r. + apply shiftr_eq_0_max_bound; intuition. + - rewrite nth_default_out_of_bounds; try split; try omega; auto. + + specialize (Hbounds i). + split; intuition. + apply max_bound_shiftr_eq_0; auto. + rewrite <-max_bound_log_cap in *; omega. + Qed. + + Lemma carry_carry_done_done : forall i us, + (length us = length base)%nat -> + (i < length base)%nat -> + carry_done us -> carry_done (carry i us). + Proof. + unfold carry_done; intros i ? ? i_bound Hcarry_done x x_bound. + destruct (Hcarry_done x x_bound) as [lower_bound_x shiftr_0_x]. + destruct (Hcarry_done i i_bound) as [lower_bound_i shiftr_0_i]. + split. + + rewrite carry_nothing; auto. + split; [ apply Hcarry_done; auto | ]. + apply shiftr_eq_0_max_bound. + apply Hcarry_done; auto. + + unfold carry, carry_simple, carry_and_reduce; break_if; subst. + - add_set_nth; subst. + * rewrite shiftr_0_i, Z.mul_0_r, Z.add_0_l. + assumption. + * rewrite pow2_mod_log_cap_small by (intuition; auto using shiftr_eq_0_max_bound). + assumption. + - rewrite shiftr_0_i by omega. + rewrite pow2_mod_log_cap_small by (intuition; auto using shiftr_eq_0_max_bound). + add_set_nth; subst; rewrite ?Z.add_0_l; auto. + Qed. + + Lemma carry_sequence_chain_step : forall i us, + carry_sequence (make_chain (S i)) us = carry i (carry_sequence (make_chain i) us). + Proof. + reflexivity. + Qed. + Lemma carry_bounds_0_upper : forall us j, (length us = length base) -> (0 < j < length base)%nat -> nth_default 0 (carry_sequence (make_chain j) us) 0 <= max_bound 0. Proof. - unfold carry_sequence; induction j; [simpl; intros; omega | ]. - intros. - simpl in *. - destruct (eq_nat_dec 0 j). - + subst. - apply nth_default_carry_bound_upper; fold (carry_sequence (make_chain 0) us); carry_length_conditions. - + rewrite carry_unaffected_low; try omega. - fold (carry_sequence (make_chain j) us); carry_length_conditions. + induction j as [ | [ | j ] IHj ]; [simpl; intros; omega | | ]; intros. + + subst; simpl; auto. + + rewrite carry_sequence_chain_step, carry_unaffected_low; carry_length_conditions. Qed. Lemma carry_bounds_upper : forall i us j, (0 < i < j)%nat -> (length us = length base) -> @@ -721,7 +741,7 @@ Section CanonicalizationProofs. fold (carry_sequence (make_chain j) us); carry_length_conditions. Qed. - Lemma carry_sequence_unaffected : forall i us j, (j < i)%nat -> (length us = length base)%nat -> + Lemma carry_sequence_unaffected : forall i us j, (j < i)%nat -> (length us = length base)%nat -> nth_default 0 (carry_sequence (make_chain j) us) i = nth_default 0 us i. Proof. induction j; [simpl; intros; omega | ]. @@ -731,33 +751,41 @@ Section CanonicalizationProofs. apply IHj; omega. Qed. + (* makes omega run faster *) + Ltac clear_obvious := + match goal with + | [H : ?a <= ?a |- _] => clear H + | [H : ?a <= S ?a |- _] => clear H + | [H : ?a < S ?a |- _] => clear H + | [H : ?a = ?a |- _] => clear H + end. + Lemma carry_sequence_bounds_lower : forall j i us, (length us = length base) -> (forall i, 0 <= nth_default 0 us i) -> (j <= length base)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain j) us) i. Proof. - induction j; intros. - + simpl. auto. - + simpl. - destruct (lt_dec (S j) i). - - rewrite carry_unaffected_high by carry_length_conditions. - apply IHj; auto; omega. - - assert ((i = S j) \/ (i = j) \/ (i < j))%nat as cases by omega. - destruct cases as [? | [? | ?]]. - * subst. apply nth_default_carry_bound_succ_lower; carry_length_conditions. - intros. - eapply IHj; auto; omega. - * subst. apply nth_default_carry_bound_lower; carry_length_conditions. - * destruct (eq_nat_dec j (pred (length base))); - [ | rewrite carry_unaffected_low by carry_length_conditions; apply IHj; auto; omega ]. - subst. - unfold carry, carry_and_reduce; break_if; try omega. - add_set_nth; [ | apply IHj; auto; omega ]. - apply Z.add_nonneg_nonneg; [ | apply IHj; auto; omega ]. - apply Z.mul_nonneg_nonneg; try omega. - apply Z.shiftr_nonneg. - apply IHj; auto; omega. + induction j; intros; simpl; auto. + destruct (lt_dec (S j) i). + + rewrite carry_unaffected_high by carry_length_conditions. + apply IHj; auto; omega. + + assert ((i = S j) \/ (i = j) \/ (i < j))%nat as cases by omega. + destruct cases as [? | [? | ?]]. + - subst. apply nth_default_carry_bound_succ_lower; carry_length_conditions. + intros; eapply IHj; auto; omega. + - subst. apply nth_default_carry_bound_lower; carry_length_conditions. + - destruct (eq_nat_dec j (pred (length base))); + [ | rewrite carry_unaffected_low by carry_length_conditions; apply IHj; auto; omega ]. + subst. + do 2 match goal with H : appcontext[S (pred (length base))] |- _ => + erewrite <-(S_pred (length base)) in H by eauto end. + unfold carry; break_if; [ unfold carry_and_reduce | omega ]. + clear_obvious. + add_set_nth; [ zero_bounds | ]; apply IHj; auto; omega. Qed. + Ltac carry_seq_lower_bound := + repeat (intros; eapply carry_sequence_bounds_lower; eauto; carry_length_conditions). + Lemma carry_bounds_lower : forall i us j, (0 < i <= j)%nat -> (length us = length base) -> (forall i, 0 <= nth_default 0 us i) -> (j <= length base)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain j) us) i. @@ -769,13 +797,12 @@ Section CanonicalizationProofs. destruct (eq_nat_dec i (S j)). + subst. apply nth_default_carry_bound_succ_lower; auto; fold (carry_sequence (make_chain j) us); carry_length_conditions. - intros. - apply carry_sequence_bounds_lower; auto; omega. + carry_seq_lower_bound. + assert (i = j \/ i < j)%nat as cases by omega. destruct cases as [eq_j_i | lt_i_j]; subst; [apply nth_default_carry_bound_lower| rewrite carry_unaffected_low]; try omega; fold (carry_sequence (make_chain j) us); carry_length_conditions. - apply carry_sequence_bounds_lower; auto; omega. + carry_seq_lower_bound. Qed. Lemma carry_full_bounds : forall us i, (i <> 0)%nat -> (forall i, 0 <= nth_default 0 us i) -> @@ -799,18 +826,15 @@ Section CanonicalizationProofs. unfold carry, carry_simple; break_if; try omega. add_set_nth. replace (2 ^ B) with (2 ^ (B - log_cap i) + (2 ^ B - 2 ^ (B - log_cap i))) by omega. - split. - + apply Z.add_nonneg_nonneg; try omega. - apply Z.shiftr_nonneg; try omega. - + apply Z.add_lt_mono; try omega. - rewrite Z.shiftr_div_pow2 by apply log_cap_nonneg. - apply Z.div_lt_upper_bound; try apply pow_2_log_cap_pos. - rewrite <-Z.pow_add_r by (apply log_cap_nonneg || apply B_compat_log_cap). - replace (log_cap i + (B - log_cap i)) with B by ring. - omega. + split; [ zero_bounds | ]. + apply Z.add_lt_mono; try omega. + rewrite Z.shiftr_div_pow2 by apply log_cap_nonneg. + apply Z.div_lt_upper_bound; try apply pow_2_log_cap_pos. + rewrite <-Z.pow_add_r by (apply log_cap_nonneg || apply B_compat_log_cap). + replace (log_cap i + (B - log_cap i)) with B by ring. + omega. Qed. - Lemma carry_sequence_no_overflow : forall i us, pre_carry_bounds us -> (length us = length base) -> nth_default 0 (carry_sequence (make_chain i) us) i < 2 ^ B. @@ -822,16 +846,13 @@ Section CanonicalizationProofs. intuition. + simpl. destruct (lt_eq_lt_dec i (pred (length base))) as [[? | ? ] | ? ]. - - apply carry_simple_no_overflow; carry_length_conditions. - apply carry_sequence_bounds_lower; carry_length_conditions. - apply carry_sequence_bounds_lower; carry_length_conditions. - rewrite carry_sequence_unaffected; try omega. + - apply carry_simple_no_overflow; carry_length_conditions; carry_seq_lower_bound. + rewrite carry_sequence_unaffected; try omega. specialize (PCB (S i)); rewrite Nat.pred_succ in PCB. break_if; intuition. - unfold carry; break_if; try omega. rewrite nth_default_out_of_bounds; [ apply Z.pow_pos_nonneg; omega | ]. - subst. - unfold carry_and_reduce. + subst; unfold carry_and_reduce. carry_length_conditions. - rewrite nth_default_out_of_bounds; [ apply Z.pow_pos_nonneg; omega | ]. carry_length_conditions. @@ -843,25 +864,20 @@ Section CanonicalizationProofs. Proof. unfold carry_full, full_carry_chain; intros. rewrite <- base_length. - replace (length base) with (S (pred (length base))) at 1 2 by omega. + replace (length base) with (S (pred (length base))) by omega. simpl. unfold carry, carry_and_reduce; break_if; try omega. - add_set_nth. - split. - + apply Z.add_nonneg_nonneg. - - apply Z.mul_nonneg_nonneg; try omega. - apply Z.shiftr_nonneg. - apply carry_sequence_bounds_lower; auto; omega. - - apply carry_sequence_bounds_lower; auto; omega. - + rewrite Z.add_comm. - apply Z.add_le_mono. - - apply carry_bounds_0_upper; auto; omega. - - apply Z.mul_le_mono_pos_l; auto. - apply Z_shiftr_ones; auto; - [ | pose proof (B_compat_log_cap (pred (length base))); omega ]. - split. - * apply carry_bounds_lower; auto; try omega. - * apply carry_sequence_no_overflow; auto. + clear_obvious; add_set_nth. + split; [zero_bounds; carry_seq_lower_bound | ]. + rewrite Z.add_comm. + apply Z.add_le_mono. + + apply carry_bounds_0_upper; auto; omega. + + apply Z.mul_le_mono_pos_l; auto. + apply Z_shiftr_ones; auto; + [ | pose proof (B_compat_log_cap (pred (length base))); omega ]. + split. + - apply carry_bounds_lower; auto; omega. + - apply carry_sequence_no_overflow; auto. Qed. Lemma carry_full_bounds_lower : forall i us, pre_carry_bounds us -> @@ -874,12 +890,12 @@ Section CanonicalizationProofs. - apply carry_bounds_lower; carry_length_conditions. - rewrite nth_default_out_of_bounds; carry_length_conditions. Qed. - + (* END proofs about first carry loop *) - + (* BEGIN proofs about second carry loop *) - Lemma carry_sequence_carry_full_bounds_same : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_sequence_carry_full_bounds_same : forall us i, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain i) (carry_full us)) i <= 2 ^ log_cap i. Proof. @@ -888,12 +904,9 @@ Section CanonicalizationProofs. unfold carry, carry_simple; break_if; try omega. add_set_nth. split. - + apply Z.add_nonneg_nonneg. - - apply Z.shiftr_nonneg. - destruct (eq_nat_dec i 0); subst. - * simpl. - apply carry_full_bounds_0; auto. - * apply IHi; auto; omega. + + zero_bounds; [destruct (eq_nat_dec i 0); subst | ]. + - simpl; apply carry_full_bounds_0; auto. + - apply IHi; auto; omega. - rewrite carry_sequence_unaffected by carry_length_conditions. apply carry_full_bounds; auto; omega. + rewrite <-max_bound_log_cap, <-Z.add_1_l. @@ -905,16 +918,14 @@ Section CanonicalizationProofs. eapply Z.le_lt_trans; [ apply carry_full_bounds_0; auto | ]. replace (2 ^ log_cap 0 * 2) with (2 ^ log_cap 0 + 2 ^ log_cap 0) by ring. rewrite <-max_bound_log_cap, <-Z.add_1_l. - apply Z.add_lt_le_mono; try omega. - unfold c_carry_constraint in *. - intuition. + apply Z.add_lt_le_mono; omega. * eapply Z.le_lt_trans; [ apply IHi; auto; omega | ]. - apply Z.lt_mul_diag_r; auto; omega. + apply Z.lt_mul_diag_r; auto; omega. - rewrite carry_sequence_unaffected by carry_length_conditions. apply carry_full_bounds; auto; omega. Qed. - Lemma carry_full_2_bounds_0 : forall us, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds_0 : forall us, pre_carry_bounds us -> (length us = length base)%nat -> (1 < length base)%nat -> 0 <= nth_default 0 (carry_full (carry_full us)) 0 <= max_bound 0 + c. Proof. @@ -924,19 +935,14 @@ Section CanonicalizationProofs. replace (length base) with (S (pred (length base))) by (pose proof base_length_nonzero; omega). simpl. unfold carry, carry_and_reduce; break_if; try omega. - add_set_nth. + clear_obvious; add_set_nth. split. - + apply Z.add_nonneg_nonneg. - apply Z.mul_nonneg_nonneg; try omega. - apply Z.shiftr_nonneg. + + zero_bounds; [ | carry_seq_lower_bound]. apply carry_sequence_carry_full_bounds_same; auto; omega. - eapply carry_sequence_bounds_lower; eauto; carry_length_conditions. - intros. - eapply carry_sequence_bounds_lower; eauto; carry_length_conditions. + rewrite Z.add_comm. apply Z.add_le_mono. - apply carry_bounds_0_upper; carry_length_conditions. - - replace c with (c * 1) at 2 by ring. + - etransitivity; [ | replace c with (c * 1) by ring; reflexivity ]. apply Z.mul_le_mono_pos_l; try omega. rewrite Z.shiftr_div_pow2 by auto. apply Z.div_le_upper_bound; auto. @@ -945,7 +951,7 @@ Section CanonicalizationProofs. omega. Qed. - Lemma carry_full_2_bounds_succ : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds_succ : forall us i, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < pred (length base))%nat -> ((0 < i < length base)%nat -> 0 <= nth_default 0 @@ -954,20 +960,14 @@ Section CanonicalizationProofs. 0 <= nth_default 0 (carry_simple i (carry_sequence (make_chain i) (carry_full (carry_full us)))) (S i) <= 2 ^ log_cap (S i). Proof. - unfold carry_simple; intros ? ? PCB CCC length_eq ? IH. + unfold carry_simple; intros ? ? PCB length_eq ? IH. add_set_nth. split. - + apply Z.add_nonneg_nonneg. - apply Z.shiftr_nonneg. - destruct i; - [ simpl; pose proof (carry_full_2_bounds_0 us PCB CCC length_eq); omega | ]. - - assert (0 < S i < length base)%nat as IHpre by omega. - specialize (IH IHpre). - omega. - - rewrite carry_sequence_unaffected by carry_length_conditions. - apply carry_full_bounds; carry_length_conditions. - intros. - apply carry_sequence_bounds_lower; eauto; carry_length_conditions. + + zero_bounds. destruct i; + [ simpl; pose proof (carry_full_2_bounds_0 us PCB length_eq); omega | ]. + rewrite carry_sequence_unaffected by carry_length_conditions. + apply carry_full_bounds; carry_length_conditions. + carry_seq_lower_bound. + rewrite <-max_bound_log_cap, <-Z.add_1_l. rewrite Z.shiftr_div_pow2 by apply log_cap_nonneg. apply Z.add_le_mono. @@ -975,10 +975,10 @@ Section CanonicalizationProofs. ring_simplify. apply IH. omega. - rewrite carry_sequence_unaffected by carry_length_conditions. apply carry_full_bounds; carry_length_conditions. - intros; apply carry_sequence_bounds_lower; eauto; carry_length_conditions. + carry_seq_lower_bound. Qed. - Lemma carry_full_2_bounds_same : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds_same : forall us i, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain i) (carry_full (carry_full us))) i <= 2 ^ log_cap i. Proof. @@ -988,36 +988,33 @@ Section CanonicalizationProofs. split; (destruct (eq_nat_dec i 0); subst; [ cbv [make_chain carry_sequence fold_right carry_simple]; add_set_nth | eapply carry_full_2_bounds_succ; eauto; omega]). - + apply Z.add_nonneg_nonneg. - apply Z.shiftr_nonneg. - eapply carry_full_2_bounds_0; eauto. - eapply carry_full_bounds; eauto; carry_length_conditions. - intros; apply carry_sequence_bounds_lower; eauto; carry_length_conditions. + + zero_bounds. + - eapply carry_full_2_bounds_0; eauto. + - eapply carry_full_bounds; eauto; carry_length_conditions. + carry_seq_lower_bound. + rewrite <-max_bound_log_cap, <-Z.add_1_l. rewrite Z.shiftr_div_pow2 by apply log_cap_nonneg. apply Z.add_le_mono. - apply Z_div_floor; auto. eapply Z.le_lt_trans; [ eapply carry_full_2_bounds_0; eauto | ]. replace (Z.succ 1) with (2 ^ 1) by ring. - rewrite <-Z.pow_add_r by (omega || auto). - unfold c_carry_constraint in *. - intuition. - - apply carry_full_bounds; carry_length_conditions. - intros; apply carry_sequence_bounds_lower; eauto; carry_length_conditions. + rewrite <-max_bound_log_cap. + ring_simplify. omega. + - apply carry_full_bounds; carry_length_conditions; carry_seq_lower_bound. Qed. - Lemma carry_full_2_bounds' : forall us i j, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds' : forall us i j, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> (i + j < length base)%nat -> (j <> 0)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain (i + j)) (carry_full (carry_full us))) i <= max_bound i. Proof. induction j; intros; try omega. - split; (destruct j; [ rewrite Nat.add_1_r; simpl + split; (destruct j; [ rewrite Nat.add_1_r; simpl | rewrite <-plus_n_Sm; simpl; rewrite carry_unaffected_low by carry_length_conditions; eapply IHj; eauto; omega ]). + apply nth_default_carry_bound_lower; carry_length_conditions. + apply nth_default_carry_bound_upper; carry_length_conditions. Qed. - Lemma carry_full_2_bounds : forall us i j, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds : forall us i j, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> (i < j < length base)%nat -> 0 <= nth_default 0 (carry_sequence (make_chain j) (carry_full (carry_full us))) i <= max_bound i. Proof. @@ -1026,12 +1023,12 @@ Section CanonicalizationProofs. eapply carry_full_2_bounds'; eauto; omega. Qed. - Lemma carry_carry_full_2_bounds_0_lower : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_carry_full_2_bounds_0_lower : forall us i, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> (0 <= nth_default 0 (carry_sequence (make_chain i) (carry_full (carry_full us))) 0). Proof. induction i; try omega. - intros ? ? length_eq ?; simpl. + intros ? length_eq ?; simpl. destruct i. + unfold carry. break_if; @@ -1041,91 +1038,82 @@ Section CanonicalizationProofs. add_set_nth. apply pow2_mod_log_cap_bounds_lower. + rewrite carry_unaffected_low by carry_length_conditions. - assert (0 < S i < length base)%nat by omega. + assert (0 < S i < length base)%nat by omega. intuition. Qed. - Lemma carry_full_2_bounds_lower :forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_2_bounds_lower :forall us i, pre_carry_bounds us -> (length us = length base)%nat -> 0 <= nth_default 0 (carry_full (carry_full us)) i. Proof. - intros. - destruct i. + intros; destruct i. + apply carry_full_2_bounds_0; auto. + apply carry_full_bounds; try solve [carry_length_conditions]. - intro j. - destruct j. + intro j; destruct j. - apply carry_full_bounds_0; auto. - apply carry_full_bounds; carry_length_conditions. Qed. - Lemma carry_carry_full_2_bounds_0_upper : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_length : forall us, (length us = length base)%nat -> + length (carry_full us) = length us. + Proof. + intros; carry_length_conditions. + Qed. + Local Hint Resolve carry_full_length. + + Lemma carry_carry_full_2_bounds_0_upper : forall us i, pre_carry_bounds us -> (length us = length base)%nat -> (0 < i < length base)%nat -> (nth_default 0 (carry_sequence (make_chain i) (carry_full (carry_full us))) 0 <= max_bound 0 - c) \/ carry_done (carry_sequence (make_chain i) (carry_full (carry_full us))). Proof. induction i; try omega. - intros ? ? length_eq ?; simpl. + intros ? length_eq ?; simpl. destruct i. + destruct (Z_le_dec (nth_default 0 (carry_full (carry_full us)) 0) (max_bound 0)). - right. - unfold carry_done. + apply carry_carry_done_done; try solve [carry_length_conditions]. + apply carry_done_bounds; try solve [carry_length_conditions]. intros. - apply max_bound_shiftr_eq_0; simpl; rewrite carry_nothing; try solve [carry_length_conditions]. - * apply carry_full_2_bounds_lower; auto. - * split; try apply carry_full_2_bounds_lower; auto. - * destruct i; auto. - apply carry_full_bounds; try solve [carry_length_conditions]. - auto using carry_full_bounds_lower. - * split; auto. - apply carry_full_2_bounds_lower; auto. - - unfold carry. + simpl. + split; [ auto using carry_full_2_bounds_lower | ]. + * destruct i; rewrite <-max_bound_log_cap, Z.lt_succ_r; auto. + apply carry_full_bounds; auto using carry_full_bounds_lower. + rewrite carry_full_length; auto. + - left; unfold carry, carry_simple. break_if; [ pose proof base_length_nonzero; replace (length base) with 1%nat in *; omega | ]. - simpl. - unfold carry_simple. - add_set_nth. left. + add_set_nth. simpl. remember ((nth_default 0 (carry_full (carry_full us)) 0)) as x. - apply Z.le_trans with (m := (max_bound 0 + c) - (1 + max_bound 0)). - * replace x with ((x - 2 ^ log_cap 0) + (1 * 2 ^ log_cap 0)) by ring. - rewrite pow2_mod_spec by auto. - rewrite Z.mod_add by (pose proof (pow_2_log_cap_pos 0); omega). - rewrite <-max_bound_log_cap, <-Z.add_1_l, Z.mod_small. - apply Z.sub_le_mono_r. - subst; apply carry_full_2_bounds_0; auto. - split; try omega. - pose proof carry_full_2_bounds_0. - apply Z.le_lt_trans with (m := (max_bound 0 + c) - (1 + max_bound 0)); - [ apply Z.sub_le_mono_r; subst x; apply carry_full_2_bounds_0; auto; - ring_simplify; unfold c_carry_constraint in *; omega | ]. - ring_simplify; unfold c_carry_constraint in *; omega. - * ring_simplify; unfold c_carry_constraint in *; omega. + apply Z.le_trans with (m := (max_bound 0 + c) - (1 + max_bound 0)); try omega. + replace x with ((x - 2 ^ log_cap 0) + (1 * 2 ^ log_cap 0)) by ring. + rewrite pow2_mod_spec by auto. + cbv [make_chain carry_sequence fold_right]. + rewrite Z.mod_add by (pose proof (pow_2_log_cap_pos 0); omega). + rewrite <-max_bound_log_cap, <-Z.add_1_l, Z.mod_small; + [ apply Z.sub_le_mono_r; subst; apply carry_full_2_bounds_0; auto | ]. + split; try omega. + pose proof carry_full_2_bounds_0. + apply Z.le_lt_trans with (m := (max_bound 0 + c) - (1 + max_bound 0)); + [ apply Z.sub_le_mono_r; subst x; apply carry_full_2_bounds_0; auto; + ring_simplify | ]; omega. + rewrite carry_unaffected_low by carry_length_conditions. - assert (0 < S i < length base)%nat by omega. - intuition. - right. + assert (0 < S i < length base)%nat by omega. + intuition; right. apply carry_carry_done_done; try solve [carry_length_conditions]. - intro j. - destruct j. - - apply carry_carry_full_2_bounds_0_lower; auto. - - destruct (lt_eq_lt_dec j i) as [[? | ?] | ?]. - * apply carry_full_2_bounds; auto; omega. - * subst. apply carry_full_2_bounds_same; auto; omega. - * rewrite carry_sequence_unaffected; try solve [carry_length_conditions]. - apply carry_full_2_bounds_lower; auto; omega. - Qed. - + assumption. + Qed. + (* END proofs about second carry loop *) - + (* BEGIN proofs about third carry loop *) - Lemma carry_full_3_bounds : forall us i, pre_carry_bounds us -> c_carry_constraint -> + Lemma carry_full_3_bounds : forall us i, pre_carry_bounds us -> (length us = length base)%nat ->(i < length base)%nat -> 0 <= nth_default 0 (carry_full (carry_full (carry_full us))) i <= max_bound i. Proof. intros. destruct i; [ | apply carry_full_bounds; carry_length_conditions; - do 2 (intros; apply carry_sequence_bounds_lower; eauto; carry_length_conditions) ]. + carry_seq_lower_bound ]. unfold carry_full at 1 4, full_carry_chain. case_eq limb_widths; [intros; pose proof limb_widths_nonnil; congruence | ]. simpl. @@ -1135,45 +1123,967 @@ Section CanonicalizationProofs. unfold carry, carry_and_reduce; break_if; try omega; intros. add_set_nth. split. - + apply Z.add_nonneg_nonneg. - - apply Z.mul_nonneg_nonneg; auto; try omega. - apply Z.shiftr_nonneg. - eapply carry_full_2_bounds_same; eauto; omega. + + zero_bounds. + - eapply carry_full_2_bounds_same; eauto; omega. - eapply carry_carry_full_2_bounds_0_lower; eauto; omega. + pose proof (carry_carry_full_2_bounds_0_upper us (pred (length base))). assert (0 < pred (length base) < length base)%nat by omega. intuition. - replace (max_bound 0) with (c + (max_bound 0 - c)) by ring. apply Z.add_le_mono; try assumption. - replace c with (c * 1) at 2 by ring. + etransitivity; [ | replace c with (c * 1) by ring; reflexivity ]. apply Z.mul_le_mono_pos_l; try omega. rewrite Z.shiftr_div_pow2 by auto. apply Z.div_le_upper_bound; auto. ring_simplify. apply carry_full_2_bounds_same; auto. - - match goal with H : carry_done _ |- _ => unfold carry_done in H; rewrite H by omega end. + - match goal with H0 : (pred (length base) < length base)%nat, + H : carry_done _ |- _ => + destruct (H (pred (length base)) H0) as [Hcd1 Hcd2]; rewrite Hcd2 by omega end. ring_simplify. - apply shiftr_eq_0_max_bound; auto; omega. + apply shiftr_eq_0_max_bound; auto. + assert (0 < length base)%nat as zero_lt_length by omega. + match goal with H : carry_done _ |- _ => + destruct (H 0%nat zero_lt_length) end. + assumption. Qed. - Lemma nth_error_combine : forall {A B} i (x : A) (x' : B) l l', nth_error l i = Some x -> - nth_error l' i = Some x' -> nth_error (combine l l') i = Some (x, x'). - Admitted. - - Lemma nth_error_range : forall {A} i (l : list A), (i < length l)%nat -> - nth_error (range (length l)) i = Some i. - Admitted. + Lemma carry_full_3_done : forall us, pre_carry_bounds us -> + (length us = length base)%nat -> + carry_done (carry_full (carry_full (carry_full us))). + Proof. + intros. + apply carry_done_bounds; [ carry_length_conditions | intros ]. + destruct (lt_dec i (length base)). + + rewrite <-max_bound_log_cap, Z.lt_succ_r. + auto using carry_full_3_bounds. + + rewrite nth_default_out_of_bounds; carry_length_conditions. + Qed. (* END proofs about third carry loop *) - Opaque carry_full. - Lemma freeze_in_bounds : forall us i, (us <> nil)%nat -> - 0 <= nth_default 0 (freeze us) i < 2 ^ log_cap i. + Lemma isFull'_false : forall us n, isFull' us false n = false. Proof. - Admitted. + unfold isFull'; induction n; intros; rewrite Bool.andb_false_r; auto. + Qed. - Lemma freeze_canonical : forall us vs x, rep us x -> rep vs x -> + Lemma isFull'_last : forall us b j, (j <> 0)%nat -> isFull' us b j = true -> + max_bound j = nth_default 0 us j. + Proof. + induction j; simpl; intros; try omega. + match goal with + | [H : isFull' _ ((?comp ?a ?b) && _) _ = true |- _ ] => + case_eq (comp a b); rewrite ?Z.eqb_eq; intro comp_eq; try assumption; + rewrite comp_eq, Bool.andb_false_l, isFull'_false in H; congruence + end. + Qed. + + Lemma isFull'_lower_bound_0 : forall j us b, isFull' us b j = true -> + max_bound 0 - c < nth_default 0 us 0. + Proof. + induction j; intros. + + match goal with H : isFull' _ _ 0 = _ |- _ => cbv [isFull'] in H; + apply Bool.andb_true_iff in H; destruct H end. + apply Z.ltb_lt; assumption. + + eauto. + Qed. + + Lemma isFull'_true_full : forall us i j b, (i <> 0)%nat -> (i <= j)%nat -> isFull' us b j = true -> + max_bound i = nth_default 0 us i. + Proof. + induction j; intros; try omega. + assert (i = S j \/ i <= j)%nat as cases by omega. + destruct cases. + + subst. eapply isFull'_last; eauto. + + eapply IHj; eauto. + Qed. + + Lemma max_ones_nonneg : 0 <= max_ones. + Proof. + unfold max_ones. + apply Z_ones_nonneg. + pose proof limb_widths_nonneg. + induction limb_widths. + cbv; congruence. + simpl. + apply Z.max_le_iff. + right. + apply IHl; auto using in_cons. + Qed. + + Lemma land_max_ones_noop : forall x i, 0 <= x < 2 ^ log_cap i -> Z.land max_ones x = x. + Proof. + unfold max_ones. + intros ? ? x_range. + rewrite Z.land_comm. + rewrite Z.land_ones by apply Z_le_fold_right_max_initial. + apply Z.mod_small. + split; try omega. + eapply Z.lt_le_trans; try eapply x_range. + apply Z.pow_le_mono_r; try omega. + rewrite log_cap_eq. + destruct (lt_dec i (length limb_widths)). + + apply Z_le_fold_right_max. + - apply limb_widths_nonneg. + - rewrite nth_default_eq. + auto using nth_In. + + rewrite nth_default_out_of_bounds by omega. + apply Z_le_fold_right_max_initial. + Qed. + + Lemma full_isFull'_true : forall j us, (length us = length base) -> + ( max_bound 0 - c < nth_default 0 us 0 + /\ (forall i, (0 < i <= j)%nat -> nth_default 0 us i = max_bound i)) -> + isFull' us true j = true. + Proof. + induction j; intros. + + cbv [isFull']; apply Bool.andb_true_iff. + rewrite Z.ltb_lt; intuition. + + intuition. + simpl. + match goal with H : forall j, _ -> ?b j = ?a j |- appcontext[?a ?i =? ?b ?i] => + replace (a i =? b i) with true by (symmetry; apply Z.eqb_eq; symmetry; apply H; omega) end. + apply IHj; auto; intuition. + Qed. + + Lemma isFull'_true_iff : forall j us, (length us = length base) -> (isFull' us true j = true <-> + max_bound 0 - c < nth_default 0 us 0 + /\ (forall i, (0 < i <= j)%nat -> nth_default 0 us i = max_bound i)). + Proof. + intros; split; intros; auto using full_isFull'_true. + split; eauto using isFull'_lower_bound_0. + intros. + symmetry; eapply isFull'_true_full; [ omega | | eauto]. + omega. + Qed. + + Lemma isFull'_true_step : forall us j, isFull' us true (S j) = true -> + isFull' us true j = true. + Proof. + simpl; intros ? ? succ_true. + destruct (max_bound (S j) =? nth_default 0 us (S j)); auto. + rewrite isFull'_false in succ_true. + congruence. + Qed. + + Opaque isFull' max_ones. + + Lemma carry_full_3_length : forall us, (length us = length base) -> + length (carry_full (carry_full (carry_full us))) = length us. + Proof. + intros. + repeat rewrite carry_full_length by (repeat rewrite carry_full_length; auto); auto. + Qed. + Local Hint Resolve carry_full_3_length. + + Lemma nth_default_map2 : forall {A B C} (f : A -> B -> C) ls1 ls2 i d d1 d2, + nth_default d (map2 f ls1 ls2) i = + if lt_dec i (min (length ls1) (length ls2)) + then f (nth_default d1 ls1 i) (nth_default d2 ls2 i) + else d. + Proof. + induction ls1, ls2. + + cbv [map2 length min]. + intros. + break_if; try omega. + apply nth_default_nil. + + cbv [map2 length min]. + intros. + break_if; try omega. + apply nth_default_nil. + + cbv [map2 length min]. + intros. + break_if; try omega. + apply nth_default_nil. + + simpl. + destruct i. + - intros. rewrite !nth_default_cons. + break_if; auto; omega. + - intros. rewrite !nth_default_cons_S. + rewrite IHls1 with (d1 := d1) (d2 := d2). + repeat break_if; auto; omega. + Qed. + + Lemma map2_cons : forall A B C (f : A -> B -> C) ls1 ls2 a b, + map2 f (a :: ls1) (b :: ls2) = f a b :: map2 f ls1 ls2. + Proof. + reflexivity. + Qed. + + Lemma map2_nil_l : forall A B C (f : A -> B -> C) ls2, + map2 f nil ls2 = nil. + Proof. + reflexivity. + Qed. + + Lemma map2_nil_r : forall A B C (f : A -> B -> C) ls1, + map2 f ls1 nil = nil. + Proof. + destruct ls1; reflexivity. + Qed. + Local Hint Resolve map2_nil_r map2_nil_l. + + Opaque map2. + + Lemma map2_length : forall A B C (f : A -> B -> C) ls1 ls2, + length (map2 f ls1 ls2) = min (length ls1) (length ls2). + Proof. + induction ls1, ls2; intros; try solve [cbv; auto]. + rewrite map2_cons, !length_cons, IHls1. + auto. + Qed. + + Lemma modulus_digits'_length : forall i, length (modulus_digits' i) = S i. + Proof. + induction i; intros; [ cbv; congruence | ]. + unfold modulus_digits'; fold modulus_digits'. + rewrite app_length, IHi. + cbv [length]; omega. + Qed. + + Lemma modulus_digits_length : length modulus_digits = length base. + Proof. + unfold modulus_digits. + rewrite modulus_digits'_length; omega. + Qed. + + (* Helps with solving goals of the form [x = y -> min x y = x] or [x = y -> min x y = y] *) + Local Hint Resolve Nat.eq_le_incl eq_le_incl_rev. + + Hint Rewrite app_length cons_length map2_length modulus_digits_length length_zeros + map_length combine_length firstn_length map_app : lengths. + Ltac simpl_lengths := autorewrite with lengths; + repeat rewrite carry_full_length by (repeat rewrite carry_full_length; auto); + auto using Min.min_l; auto using Min.min_r. + + Lemma freeze_length : forall us, (length us = length base) -> + length (freeze us) = length us. + Proof. + unfold freeze; intros; simpl_lengths. + Qed. + + Lemma decode_firstn_succ : forall n us, (length us = length base) -> + (n < length base)%nat -> + BaseSystem.decode' (firstn (S n) base) (firstn (S n) us) = + BaseSystem.decode' (firstn n base) (firstn n us) + + nth_default 0 base n * nth_default 0 us n. + Proof. + intros. + rewrite !firstn_succ with (d := 0) by omega. + rewrite base_app, firstn_app. + autorewrite with lengths; rewrite !Min.min_l by omega. + rewrite Nat.sub_diag, firstn_firstn, firstn0, app_nil_r by omega. + rewrite skipn_app_sharp by (autorewrite with lengths; apply Min.min_l; omega). + rewrite decode'_cons, decode_nil, Z.add_0_r. + reflexivity. + Qed. + + Local Hint Resolve sum_firstn_limb_widths_nonneg. + Local Hint Resolve limb_widths_nonneg. + Local Hint Resolve nth_error_value_In. + + (* TODO : move *) + Lemma sum_firstn_all_succ : forall n l, (length l <= n)%nat -> + sum_firstn l (S n) = sum_firstn l n. + Proof. + unfold sum_firstn; intros. + rewrite !firstn_all_strong by omega. + congruence. + Qed. + + Lemma decode_carry_done_upper_bound' : forall n us, carry_done us -> + (length us = length base) -> + BaseSystem.decode (firstn n base) (firstn n us) < 2 ^ (sum_firstn limb_widths n). + Proof. + induction n; intros; [ cbv; congruence | ]. + destruct (lt_dec n (length base)) as [ n_lt_length | ? ]. + + rewrite decode_firstn_succ; auto. + rewrite base_length in n_lt_length. + destruct (nth_error_length_exists_value _ _ n_lt_length). + erewrite sum_firstn_succ; eauto. + rewrite Z.pow_add_r; eauto. + rewrite nth_default_base by (rewrite base_length; assumption). + rewrite Z.lt_add_lt_sub_r. + eapply Z.lt_le_trans; eauto. + rewrite Z.mul_comm at 1. + rewrite <-Z.mul_sub_distr_l. + rewrite <-Z.mul_1_r at 1. + apply Z.mul_le_mono_nonneg_l; [ apply Z.pow_nonneg; omega | ]. + replace 1 with (Z.succ 0) by reflexivity. + rewrite Z.le_succ_l, Z.lt_0_sub. + match goal with H : carry_done us |- _ => rewrite carry_done_bounds in H by auto; specialize (H n) end. + replace x with (log_cap n); try intuition. + rewrite log_cap_eq. + apply nth_error_value_eq_nth_default; auto. + + repeat erewrite firstn_all_strong by omega. + rewrite sum_firstn_all_succ by (rewrite <-base_length; omega). + eapply Z.le_lt_trans; [ | eauto]. + repeat erewrite firstn_all_strong by omega. + omega. + Qed. + + Lemma decode_carry_done_upper_bound : forall us, carry_done us -> + (length us = length base) -> BaseSystem.decode base us < 2 ^ k. + Proof. + unfold k; intros. + rewrite <-(firstn_all_strong base (length limb_widths)) by (rewrite <-base_length; auto). + rewrite <-(firstn_all_strong us (length limb_widths)) by (rewrite <-base_length; auto). + auto using decode_carry_done_upper_bound'. + Qed. + + Lemma decode_carry_done_lower_bound' : forall n us, carry_done us -> + (length us = length base) -> + 0 <= BaseSystem.decode (firstn n base) (firstn n us). + Proof. + induction n; intros; [ cbv; congruence | ]. + destruct (lt_dec n (length base)) as [ n_lt_length | ? ]. + + rewrite decode_firstn_succ by auto. + zero_bounds. + - rewrite nth_default_base by assumption. + apply Z.pow_nonneg; omega. + - match goal with H : carry_done us |- _ => rewrite carry_done_bounds in H by auto; specialize (H n) end. + intuition. + + eapply Z.le_trans; [ apply IHn; eauto | ]. + repeat rewrite firstn_all_strong by omega. + omega. + Qed. + + Lemma decode_carry_done_lower_bound : forall us, carry_done us -> + (length us = length base) -> 0 <= BaseSystem.decode base us. + Proof. + intros. + rewrite <-(firstn_all_strong base (length limb_widths)) by (rewrite <-base_length; auto). + rewrite <-(firstn_all_strong us (length limb_widths)) by (rewrite <-base_length; auto). + auto using decode_carry_done_lower_bound'. + Qed. + + + Lemma nth_default_modulus_digits' : forall d j i, + nth_default d (modulus_digits' j) i = + if lt_dec i (S j) + then (if (eq_nat_dec i 0) then max_bound i - c + 1 else max_bound i) + else d. + Proof. + induction j; intros; (break_if; [| apply nth_default_out_of_bounds; rewrite modulus_digits'_length; omega]). + + replace i with 0%nat by omega. + apply nth_default_cons. + + simpl. rewrite nth_default_app. + rewrite modulus_digits'_length. + break_if. + - rewrite IHj; break_if; try omega; reflexivity. + - replace i with (S j) by omega. + rewrite Nat.sub_diag, nth_default_cons. + reflexivity. + Qed. + + Lemma nth_default_modulus_digits : forall d i, + nth_default d modulus_digits i = + if lt_dec i (length base) + then (if (eq_nat_dec i 0) then max_bound i - c + 1 else max_bound i) + else d. + Proof. + unfold modulus_digits; intros. + rewrite nth_default_modulus_digits'. + replace (S (length base - 1)) with (length base) by omega. + reflexivity. + Qed. + + Lemma carry_done_modulus_digits : carry_done modulus_digits. + Proof. + apply carry_done_bounds; [apply modulus_digits_length | ]. + intros. + rewrite nth_default_modulus_digits. + break_if; [ | split; auto; omega]. + break_if; subst; split; auto; try rewrite <- max_bound_log_cap; omega. + Qed. + Local Hint Resolve carry_done_modulus_digits. + + (* TODO : move *) + Lemma decode_mod : forall us vs x, (length us = length base) -> (length vs = length base) -> + decode us = x -> + BaseSystem.decode base us mod modulus = BaseSystem.decode base vs mod modulus -> + decode vs = x. + Proof. + unfold decode; intros until 2; intros decode_us_x BSdecode_eq. + rewrite ZToField_mod in decode_us_x |- *. + rewrite <-BSdecode_eq. + assumption. + Qed. + + Ltac simpl_list_lengths := repeat match goal with + | H : appcontext[length (@nil ?A)] |- _ => rewrite (@nil_length0 A) in H + | H : appcontext[length (_ :: _)] |- _ => rewrite length_cons in H + | |- appcontext[length (@nil ?A)] => rewrite (@nil_length0 A) + | |- appcontext[length (_ :: _)] => rewrite length_cons + end. + + Lemma map2_app : forall A B C (f : A -> B -> C) ls1 ls2 ls1' ls2', + (length ls1 = length ls2) -> + map2 f (ls1 ++ ls1') (ls2 ++ ls2') = map2 f ls1 ls2 ++ map2 f ls1' ls2'. + Proof. + induction ls1, ls2; intros; rewrite ?map2_nil_r, ?app_nil_l; try congruence; + simpl_list_lengths; try omega. + rewrite <-!app_comm_cons, !map2_cons. + rewrite IHls1; auto. + Qed. + + Lemma decode_map2_sub : forall us vs, + (length us = length vs) -> + BaseSystem.decode' base (map2 (fun x y => x - y) us vs) + = BaseSystem.decode' base us - BaseSystem.decode' base vs. + Proof. + induction us using rev_ind; induction vs using rev_ind; + intros; autorewrite with lengths in *; simpl_list_lengths; + rewrite ?decode_nil; try omega. + rewrite map2_app by omega. + rewrite map2_cons, map2_nil_l. + rewrite !set_higher. + autorewrite with lengths. + rewrite Min.min_l by omega. + rewrite IHus by omega. + replace (length vs) with (length us) by omega. + ring. + Qed. + + Lemma decode_modulus_digits' : forall i, (i <= length base)%nat -> + BaseSystem.decode' base (modulus_digits' i) = 2 ^ (sum_firstn limb_widths (S i)) - c. + Proof. + induction i; intros; unfold modulus_digits'; fold modulus_digits'. + + case_eq base; + [ intro base_eq; rewrite base_eq, (@nil_length0 Z) in lt_1_length_base; omega | ]. + intros z ? base_eq. + rewrite decode'_cons, decode_nil, Z.add_0_r. + replace z with (nth_default 0 base 0) by (rewrite base_eq; auto). + rewrite nth_default_base by omega. + replace (max_bound 0 - c + 1) with (Z.succ (max_bound 0) - c) by ring. + rewrite max_bound_log_cap. + rewrite sum_firstn_succ with (x := log_cap 0) by (rewrite log_cap_eq; + apply nth_error_Some_nth_default; rewrite <-base_length; omega). + rewrite Z.pow_add_r by auto. + cbv [sum_firstn fold_right firstn]. + ring. + + assert (S i < length base \/ S i = length base)%nat as cases by omega. + destruct cases. + - rewrite sum_firstn_succ with (x := log_cap (S i)) by + (rewrite log_cap_eq; apply nth_error_Some_nth_default; + rewrite <-base_length; omega). + rewrite Z.pow_add_r, <-max_bound_log_cap, set_higher by auto. + rewrite IHi, modulus_digits'_length, nth_default_base by omega. + ring. + - rewrite sum_firstn_all_succ by (rewrite <-base_length; omega). + rewrite decode'_splice, modulus_digits'_length, firstn_all by auto. + rewrite skipn_all, decode_base_nil, Z.add_0_r by omega. + apply IHi. + omega. + Qed. + + Lemma decode_modulus_digits : BaseSystem.decode' base modulus_digits = modulus. + Proof. + unfold modulus_digits; rewrite decode_modulus_digits' by omega. + replace (S (length base - 1)) with (length base) by omega. + rewrite base_length. + fold k. unfold c. + ring. + Qed. + + Lemma map_land_max_ones_modulus_digits' : forall i, + map (Z.land max_ones) (modulus_digits' i) = (modulus_digits' i). + Proof. + induction i; intros. + + cbv [modulus_digits' map]. + f_equal. + apply land_max_ones_noop with (i := 0%nat). + rewrite <-max_bound_log_cap. + omega. + + unfold modulus_digits'; fold modulus_digits'. + rewrite map_app. + f_equal; [ apply IHi; omega | ]. + cbv [map]; f_equal. + apply land_max_ones_noop with (i := S i). + rewrite <-max_bound_log_cap. + split; auto; omega. + Qed. + + Lemma map_land_max_ones_modulus_digits : map (Z.land max_ones) modulus_digits = modulus_digits. + Proof. + apply map_land_max_ones_modulus_digits'. + Qed. + + Opaque modulus_digits. + + Lemma map_land_zero : forall ls, map (Z.land 0) ls = BaseSystem.zeros (length ls). + Proof. + induction ls; boring. + Qed. + + Lemma carry_full_preserves_Fdecode : forall us x, (length us = length base) -> + decode us = x -> decode (carry_full us) = x. + Proof. + intros. + apply carry_full_preserves_rep; auto. + unfold rep; auto. + Qed. + + Lemma freeze_preserves_rep : forall us x, rep us x -> rep (freeze us) x. + Proof. + unfold rep; intros. + intuition; rewrite ?freeze_length; auto. + unfold freeze, and_term. + break_if. + + apply decode_mod with (us := carry_full (carry_full (carry_full us))). + - rewrite carry_full_3_length; auto. + - autorewrite with lengths. + apply Min.min_r. + simpl_lengths; omega. + - repeat apply carry_full_preserves_rep; repeat rewrite carry_full_length; auto. + unfold rep; intuition. + - rewrite decode_map2_sub by (simpl_lengths; omega). + rewrite map_land_max_ones_modulus_digits. + rewrite decode_modulus_digits. + destruct (Z_eq_dec modulus 0); [ subst; rewrite !Zmod_0_r; reflexivity | ]. + rewrite <-Z.add_opp_r. + replace (-modulus) with (-1 * modulus) by ring. + symmetry; auto using Z.mod_add. + + eapply decode_mod; eauto. + simpl_lengths. + rewrite map_land_zero, decode_map2_sub, zeros_rep, Z.sub_0_r by simpl_lengths. + match goal with H : decode ?us = ?x |- _ => erewrite Fdecode_decode_mod; eauto; + do 3 apply carry_full_preserves_Fdecode in H; simpl_lengths + end. + erewrite Fdecode_decode_mod; eauto; simpl_lengths. + Qed. + Hint Resolve freeze_preserves_rep. + + Lemma isFull_true_iff : forall us, (length us = length base) -> (isFull us = true <-> + max_bound 0 - c < nth_default 0 us 0 + /\ (forall i, (0 < i <= length base - 1)%nat -> nth_default 0 us i = max_bound i)). + Proof. + unfold isFull; intros; auto using isFull'_true_iff. + Qed. + + Definition minimal_rep us := BaseSystem.decode base us = (BaseSystem.decode base us) mod modulus. + + Fixpoint compare' us vs i := + match i with + | O => Eq + | S i' => if Z_eq_dec (nth_default 0 us i') (nth_default 0 vs i') + then compare' us vs i' + else Z.compare (nth_default 0 us i') (nth_default 0 vs i') + end. + + (* Lexicographically compare two vectors of equal length, starting from the END of the list + (in our context, this is the most significant end). NOT constant time. *) + Definition compare us vs := compare' us vs (length us). + + Lemma compare'_Eq : forall us vs i, (length us = length vs) -> + compare' us vs i = Eq -> firstn i us = firstn i vs. + Proof. + induction i; intros; [ cbv; congruence | ]. + destruct (lt_dec i (length us)). + + repeat rewrite firstn_succ with (d := 0) by omega. + match goal with H : compare' _ _ (S _) = Eq |- _ => + inversion H end. + break_if; f_equal; auto. + - f_equal; auto. + - rewrite Z.compare_eq_iff in *. congruence. + - rewrite Z.compare_eq_iff in *. congruence. + + rewrite !firstn_all_strong in IHi by omega. + match goal with H : compare' _ _ (S _) = Eq |- _ => + inversion H end. + rewrite (nth_default_out_of_bounds i us) in * by omega. + rewrite (nth_default_out_of_bounds i vs) in * by omega. + break_if; try congruence. + f_equal; auto. + Qed. + + Lemma compare_Eq : forall us vs, (length us = length vs) -> + compare us vs = Eq -> us = vs. + Proof. + intros. + erewrite <-(firstn_all _ us); eauto. + erewrite <-(firstn_all _ vs); eauto. + apply compare'_Eq; auto. + Qed. + + Lemma decode_lt_next_digit : forall us n, (length us = length base) -> + (n < length base)%nat -> (n < length us)%nat -> + carry_done us -> + BaseSystem.decode' (firstn n base) (firstn n us) < + (nth_default 0 base n). + Proof. + induction n; intros ? ? ? bounded. + + cbv [firstn]. + rewrite decode_base_nil. + apply Z.gt_lt; auto using nth_default_base_positive. + + rewrite decode_firstn_succ by (auto || omega). + rewrite nth_default_base_succ by omega. + eapply Z.lt_le_trans. + - apply Z.add_lt_mono_r. + apply IHn; auto; omega. + - rewrite <-(Z.mul_1_r (nth_default 0 base n)) at 1. + rewrite <-Z.mul_add_distr_l, Z.mul_comm. + apply Z.mul_le_mono_pos_r. + * apply Z.gt_lt. apply nth_default_base_positive; omega. + * rewrite Z.add_1_l. + apply Z.le_succ_l. + rewrite carry_done_bounds in bounded by assumption. + apply bounded. + Qed. + + Lemma highest_digit_determines : forall us vs n x, (x < 0) -> + (length us = length base) -> + (length vs = length base) -> + (n < length us)%nat -> carry_done us -> + (n < length vs)%nat -> carry_done vs -> + BaseSystem.decode (firstn n base) (firstn n us) + + nth_default 0 base n * x - + BaseSystem.decode (firstn n base) (firstn n vs) < 0. + Proof. + intros. + eapply Z.le_lt_trans. + + apply Z.le_sub_nonneg. + apply decode_carry_done_lower_bound'; auto. + + eapply Z.le_lt_trans. + - eapply Z.add_le_mono with (q := nth_default 0 base n * -1); [ apply Z.le_refl | ]. + apply Z.mul_le_mono_nonneg_l; try omega. + rewrite nth_default_base by omega; apply Z.pow_nonneg; omega. + - ring_simplify. + apply Z.lt_sub_0. + apply decode_lt_next_digit; auto. + omega. + Qed. + + Lemma Z_compare_decode_step_eq : forall n us vs, + (length us = length base) -> + (length us = length vs) -> + (S n <= length base)%nat -> + (nth_default 0 us n = nth_default 0 vs n) -> + (BaseSystem.decode (firstn (S n) base) us ?= + BaseSystem.decode (firstn (S n) base) vs) = + (BaseSystem.decode (firstn n base) us ?= + BaseSystem.decode (firstn n base) vs). + Proof. + intros until 3; intro nth_default_eq. + destruct (lt_dec n (length us)); try omega. + rewrite firstn_succ with (d := 0), !base_app by omega. + autorewrite with lengths; rewrite Min.min_l by omega. + do 2 (rewrite skipn_nth_default with (d := 0) by omega; + rewrite decode'_cons, decode_base_nil, Z.add_0_r). + rewrite Z.compare_sub, nth_default_eq, Z.add_add_simpl_r_r. + rewrite BaseSystem.decode'_truncate with (us := us). + rewrite BaseSystem.decode'_truncate with (us := vs). + rewrite firstn_length, Min.min_l, <-Z.compare_sub by omega. + reflexivity. + Qed. + + Lemma Z_compare_decode_step_lt : forall n us vs, + (length us = length base) -> + (length us = length vs) -> + (S n <= length base)%nat -> + carry_done us -> carry_done vs -> + (nth_default 0 us n < nth_default 0 vs n) -> + (BaseSystem.decode (firstn (S n) base) us ?= + BaseSystem.decode (firstn (S n) base) vs) = Lt. + Proof. + intros until 5; intro nth_default_lt. + destruct (lt_dec n (length us)). + + rewrite firstn_succ with (d := 0) by omega. + rewrite !base_app. + autorewrite with lengths; rewrite Min.min_l by omega. + do 2 (rewrite skipn_nth_default with (d := 0) by omega; + rewrite decode'_cons, decode_base_nil, Z.add_0_r). + rewrite Z.compare_sub. + apply Z.compare_lt_iff. + ring_simplify. + rewrite <-Z.add_sub_assoc. + rewrite <-Z.mul_sub_distr_l. + apply highest_digit_determines; auto; omega. + + rewrite !nth_default_out_of_bounds in nth_default_lt; omega. + Qed. + + Lemma Z_compare_decode_step_neq : forall n us vs, + (length us = length base) -> (length us = length vs) -> + (S n <= length base)%nat -> + carry_done us -> carry_done vs -> + (nth_default 0 us n <> nth_default 0 vs n) -> + (BaseSystem.decode (firstn (S n) base) us ?= + BaseSystem.decode (firstn (S n) base) vs) = + (nth_default 0 us n ?= nth_default 0 vs n). + Proof. + intros. + destruct (Z_dec (nth_default 0 us n) (nth_default 0 vs n)) as [[?|Hgt]|?]; try congruence. + + etransitivity; try apply Z_compare_decode_step_lt; auto. + + match goal with |- (?a ?= ?b) = (?c ?= ?d) => + rewrite (Z.compare_antisym b a); rewrite (Z.compare_antisym d c) end. + apply CompOpp_inj; rewrite !CompOpp_involutive. + apply gt_lt_symmetry in Hgt. + etransitivity; try apply Z_compare_decode_step_lt; auto; omega. + Qed. + + Lemma decode_compare' : forall n us vs, + (length us = length base) -> + (length us = length vs) -> + (n <= length base)%nat -> + carry_done us -> carry_done vs -> + (BaseSystem.decode (firstn n base) us ?= BaseSystem.decode (firstn n base) vs) + = compare' us vs n. + Proof. + induction n; intros. + + cbv [firstn compare']; rewrite !decode_base_nil; auto. + + unfold compare'; fold compare'. + break_if. + - rewrite Z_compare_decode_step_eq by (auto || omega). + apply IHn; auto; omega. + - rewrite Z_compare_decode_step_neq; (auto || omega). + Qed. + + Lemma decode_compare : forall us vs, + (length us = length base) -> carry_done us -> + (length vs = length base) -> carry_done vs -> + Z.compare (BaseSystem.decode base us) (BaseSystem.decode base vs) = compare us vs. + Proof. + unfold compare; intros. + erewrite <-(firstn_all _ base). + + apply decode_compare'; auto; omega. + + assumption. + Qed. + + Lemma compare'_succ : forall us j vs, compare' us vs (S j) = + if Z.eq_dec (nth_default 0 us j) (nth_default 0 vs j) + then compare' us vs j + else nth_default 0 us j ?= nth_default 0 vs j. + Proof. + reflexivity. + Qed. + + Lemma compare'_firstn_r_small_index : forall us j vs, (j <= length vs)%nat -> + compare' us vs j = compare' us (firstn j vs) j. + Proof. + induction j; intros; auto. + rewrite !compare'_succ by omega. + rewrite firstn_succ with (d := 0) by omega. + rewrite nth_default_app. + simpl_lengths. + rewrite Min.min_l by omega. + destruct (lt_dec j j); try omega. + rewrite Nat.sub_diag. + rewrite nth_default_cons. + break_if; try reflexivity. + rewrite IHj with (vs := firstn j vs ++ nth_default 0 vs j :: nil) by + (autorewrite with lengths; rewrite Min.min_l; omega). + rewrite firstn_app_sharp by (autorewrite with lengths; apply Min.min_l; omega). + apply IHj; omega. + Qed. + + Lemma compare'_firstn_r : forall us j vs, + compare' us vs j = compare' us (firstn j vs) j. + Proof. + intros. + destruct (le_dec j (length vs)). + + auto using compare'_firstn_r_small_index. + + f_equal. symmetry. + apply firstn_all_strong. + omega. + Qed. + + Lemma compare'_not_Lt : forall us vs j, j <> 0%nat -> + (forall i, (0 < i < j)%nat -> 0 <= nth_default 0 us i <= nth_default 0 vs i) -> + compare' us vs j <> Lt -> + nth_default 0 vs 0 <= nth_default 0 us 0 /\ + (forall i : nat, (0 < i < j)%nat -> nth_default 0 us i = nth_default 0 vs i). + Proof. + induction j; try congruence. + rewrite compare'_succ. + intros; destruct (eq_nat_dec j 0). + + break_if; subst; split; intros; try omega. + rewrite Z.compare_ge_iff in *; omega. + + break_if. + - split; intros; [ | destruct (eq_nat_dec i j); subst; auto ]; + apply IHj; auto; intros; try omega; + match goal with H : forall i, _ -> 0 <= ?f i <= ?g i |- 0 <= ?f _ <= ?g _ => + apply H; omega end. + - exfalso. rewrite Z.compare_ge_iff in *. + match goal with H : forall i, ?P -> 0 <= ?f i <= ?g i |- _ => + specialize (H j) end; omega. + Qed. + + Lemma isFull'_compare' : forall us j, j <> 0%nat -> (length us = length base) -> + (j <= length base)%nat -> carry_done us -> + (isFull' us true (j - 1) = true <-> compare' us modulus_digits j <> Lt). + Proof. + unfold compare; induction j; intros; try congruence. + replace (S j - 1)%nat with j by omega. + split; intros. + + simpl. + break_if; [destruct (eq_nat_dec j 0) | ]. + - subst. cbv; congruence. + - apply IHj; auto; try omega. + apply isFull'_true_step. + replace (S (j - 1)) with j by omega; auto. + - rewrite nth_default_modulus_digits in *. + repeat (break_if; try omega). + * subst. + match goal with H : isFull' _ _ _ = true |- _ => + apply isFull'_lower_bound_0 in H end. + apply Z.compare_ge_iff. + omega. + * match goal with H : isFull' _ _ _ = true |- _ => + apply isFull'_true_iff in H; try assumption; destruct H as [? eq_max_bound] end. + specialize (eq_max_bound j). + omega. + + apply isFull'_true_iff; try assumption. + match goal with H : compare' _ _ _ <> Lt |- _ => apply compare'_not_Lt in H; [ destruct H as [Hdigit0 Hnonzero] | | ] end. + - split; [ | intros i i_range; assert (0 < i < S j)%nat as i_range' by omega; + specialize (Hnonzero i i_range')]; + rewrite nth_default_modulus_digits in *; + repeat (break_if; try omega). + - congruence. + - intros. + rewrite nth_default_modulus_digits. + repeat (break_if; try omega). + rewrite <-Z.lt_succ_r with (m := max_bound i). + rewrite max_bound_log_cap; apply carry_done_bounds; assumption. + Qed. + + Lemma isFull_compare : forall us, (length us = length base) -> carry_done us -> + (isFull us = true <-> compare us modulus_digits <> Lt). + Proof. + unfold compare, isFull; intros ? lengths_eq. intros. + rewrite lengths_eq. + apply isFull'_compare'; try omega. + assumption. + Qed. + + Lemma isFull_decode : forall us, (length us = length base) -> carry_done us -> + (isFull us = true <-> + (BaseSystem.decode base us ?= BaseSystem.decode base modulus_digits <> Lt)). + Proof. + intros. + rewrite decode_compare; autorewrite with lengths; auto. + apply isFull_compare; auto. + Qed. + + Lemma isFull_false_upper_bound : forall us, (length us = length base) -> + carry_done us -> isFull us = false -> + BaseSystem.decode base us < modulus. + Proof. + intros. + destruct (Z_lt_dec (BaseSystem.decode base us) modulus) as [? | nlt_modulus]; + [assumption | exfalso]. + apply Z.compare_nlt_iff in nlt_modulus. + rewrite <-decode_modulus_digits in nlt_modulus at 2. + apply isFull_decode in nlt_modulus; try assumption; congruence. + Qed. + + Lemma isFull_true_lower_bound : forall us, (length us = length base) -> + carry_done us -> isFull us = true -> + modulus <= BaseSystem.decode base us. + Proof. + intros. + rewrite <-decode_modulus_digits at 1. + apply Z.compare_ge_iff. + apply isFull_decode; auto. + Qed. + + Lemma freeze_in_bounds : forall us, + pre_carry_bounds us -> (length us = length base) -> + carry_done (freeze us). + Proof. + unfold freeze, and_term; intros ? PCB lengths_eq. + rewrite carry_done_bounds by simpl_lengths; intro i. + rewrite nth_default_map2 with (d1 := 0) (d2 := 0). + simpl_lengths. + break_if; [ | split; (omega || auto)]. + break_if. + + rewrite map_land_max_ones_modulus_digits. + apply isFull_true_iff in Heqb; [ | simpl_lengths]. + destruct Heqb as [first_digit high_digits]. + destruct (eq_nat_dec i 0). + - subst. + clear high_digits. + rewrite nth_default_modulus_digits. + repeat (break_if; try omega). + pose proof (carry_full_3_done us PCB lengths_eq) as cf3_done. + rewrite carry_done_bounds in cf3_done by simpl_lengths. + specialize (cf3_done 0%nat). + omega. + - assert ((0 < i <= length base - 1)%nat) as i_range by + (simpl_lengths; apply lt_min_l in l; omega). + specialize (high_digits i i_range). + clear first_digit i_range. + rewrite high_digits. + rewrite <-max_bound_log_cap. + rewrite nth_default_modulus_digits. + repeat (break_if; try omega). + * rewrite Z.sub_diag. + split; try omega. + apply Z.lt_succ_r; auto. + * rewrite Z.lt_succ_r, Z.sub_0_r. split; (omega || auto). + + rewrite map_land_zero, nth_default_zeros. + rewrite Z.sub_0_r. + apply carry_done_bounds; [ simpl_lengths | ]. + auto using carry_full_3_done. + Qed. + Local Hint Resolve freeze_in_bounds. + + Local Hint Resolve carry_full_3_done. + + Lemma freeze_minimal_rep : forall us, pre_carry_bounds us -> (length us = length base) -> + minimal_rep (freeze us). + Proof. + unfold minimal_rep, freeze, and_term. + intros. + symmetry. apply Z.mod_small. + split; break_if; rewrite decode_map2_sub; simpl_lengths. + + rewrite map_land_max_ones_modulus_digits, decode_modulus_digits. + apply Z.le_0_sub. + apply isFull_true_lower_bound; simpl_lengths. + + rewrite map_land_zero, zeros_rep, Z.sub_0_r. + apply decode_carry_done_lower_bound; simpl_lengths. + + rewrite map_land_max_ones_modulus_digits, decode_modulus_digits. + rewrite Z.lt_sub_lt_add_r. + apply Z.lt_le_trans with (m := 2 * modulus); try omega. + eapply Z.lt_le_trans; [ | apply two_pow_k_le_2modulus ]. + apply decode_carry_done_upper_bound; simpl_lengths. + + rewrite map_land_zero, zeros_rep, Z.sub_0_r. + apply isFull_false_upper_bound; simpl_lengths. + Qed. + Local Hint Resolve freeze_minimal_rep. + + Lemma rep_decode_mod : forall us vs x, rep us x -> rep vs x -> + (BaseSystem.decode base us) mod modulus = (BaseSystem.decode base vs) mod modulus. + Proof. + unfold rep, decode; intros. + intuition. + repeat rewrite <-FieldToZ_ZToField. + congruence. + Qed. + + Lemma minimal_rep_unique : forall us vs x, + rep us x -> minimal_rep us -> carry_done us -> + rep vs x -> minimal_rep vs -> carry_done vs -> + us = vs. + Proof. + intros. + match goal with Hrep1 : rep _ ?x, Hrep2 : rep _ ?x |- _ => + pose proof (rep_decode_mod _ _ _ Hrep1 Hrep2) as eqmod end. + repeat match goal with Hmin : minimal_rep ?us |- _ => unfold minimal_rep in Hmin; + rewrite <- Hmin in eqmod; clear Hmin end. + apply Z.compare_eq_iff in eqmod. + rewrite decode_compare in eqmod; unfold rep in *; auto; intuition; try congruence. + apply compare_Eq; auto. + congruence. + Qed. + + Lemma freeze_canonical : forall us vs x, + pre_carry_bounds us -> rep us x -> + pre_carry_bounds vs -> rep vs x -> freeze us = freeze vs. - Admitted. + Proof. + intros. + assert (length us = length base) by (unfold rep in *; intuition). + assert (length vs = length base) by (unfold rep in *; intuition). + eapply minimal_rep_unique; eauto; rewrite freeze_length; assumption. + Qed. End CanonicalizationProofs.
\ No newline at end of file diff --git a/src/ModularArithmetic/Pre.v b/src/ModularArithmetic/Pre.v index 2978fdd42..fca5576b7 100644 --- a/src/ModularArithmetic/Pre.v +++ b/src/ModularArithmetic/Pre.v @@ -2,6 +2,7 @@ Require Import Coq.ZArith.BinInt Coq.NArith.BinNat Coq.Numbers.BinNums Coq.ZArit Require Import Coq.Logic.Eqdep_dec. Require Import Coq.Logic.EqdepFacts. Require Import Crypto.Tactics.VerdiTactics. +Require Import Coq.omega.Omega. Lemma Z_mod_mod x m : x mod m = (x mod m) mod m. symmetry. @@ -46,7 +47,7 @@ Defined. Definition mulmod m := fun a b => a * b mod m. Definition powmod_pos m := Pos.iter_op (mulmod m). Definition powmod m a x := match x with N0 => 1 mod m | Npos p => powmod_pos m p (a mod m) end. - + Lemma mulmod_assoc: forall m x y z : Z, mulmod m x (mulmod m y z) = mulmod m (mulmod m x y) z. Proof. @@ -144,7 +145,7 @@ Definition mod_inv_eucl (a m:Z) : Z. (match d with Z.pos _ => u | _ => -u end) end) mod m). Defined. - + Lemma reduced_nonzero_pos: forall a m : Z, m > 0 -> a <> 0 -> a = a mod m -> 0 < a. Proof. @@ -209,7 +210,7 @@ Proof. unfold mod_inv_eucl; simpl. lazymatch goal with [ |- context [euclid ?a ?b] ] => destruct (euclid a b) end. auto. - - + - destruct a. cbv [proj1_sig mod_inv_eucl_sig]. rewrite Z.mul_comm. @@ -217,4 +218,4 @@ Proof. rewrite mod_inv_eucl_correct; eauto. intro; destruct H0. eapply exist_reduced_eq. congruence. -Qed.
\ No newline at end of file +Qed. diff --git a/src/ModularArithmetic/PrimeFieldTheorems.v b/src/ModularArithmetic/PrimeFieldTheorems.v index 70a2c4a87..2021e8514 100644 --- a/src/ModularArithmetic/PrimeFieldTheorems.v +++ b/src/ModularArithmetic/PrimeFieldTheorems.v @@ -10,6 +10,7 @@ Require Import Coq.ZArith.BinInt Coq.NArith.BinNat Coq.ZArith.ZArith Coq.ZArith. Require Import Coq.Logic.Eqdep_dec. Require Import Crypto.Util.NumTheoryUtil Crypto.Util.ZUtil. Require Import Crypto.Util.Tactics. +Require Crypto.Algebra. Existing Class prime. @@ -51,6 +52,14 @@ Section FieldModuloPre. Proof. constructor; auto using Fring_theory, Fq_1_neq_0, F_mul_inv_l. Qed. + + Global Instance field_modulo : @Algebra.field (F q) Logic.eq (ZToField 0) (ZToField 1) opp add sub mul inv div. + Proof. + constructor; try solve_proper. + - apply commutative_ring_modulo. + - split. auto using F_mul_inv_l. + - split. auto using Fq_1_neq_0. + Qed. End FieldModuloPre. Module Type PrimeModulus. diff --git a/src/ModularArithmetic/PseudoMersenneBaseParamProofs.v b/src/ModularArithmetic/PseudoMersenneBaseParamProofs.v index 1a7b3316e..49b1875ce 100644 --- a/src/ModularArithmetic/PseudoMersenneBaseParamProofs.v +++ b/src/ModularArithmetic/PseudoMersenneBaseParamProofs.v @@ -32,7 +32,7 @@ Section PseudoMersenneBaseParamProofs. unfold value in *. congruence. Qed. - + Lemma base_from_limb_widths_step : forall i b w, (S i < length base)%nat -> nth_error base i = Some b -> nth_error limb_widths i = Some w -> @@ -45,7 +45,7 @@ Section PseudoMersenneBaseParamProofs. case_eq i; intros; subst. + subst; apply nth_error_first in nth_err_w. apply nth_error_first in nth_err_b; subst. - apply map_nth_error. + apply map_nth_error. case_eq l; intros; subst; [simpl in *; omega | ]. unfold base_from_limb_widths; fold base_from_limb_widths. reflexivity. @@ -65,7 +65,7 @@ Section PseudoMersenneBaseParamProofs. apply nth_error_first in H. subst; eauto. Qed. - + Lemma sum_firstn_succ : forall l i x, nth_error l i = Some x -> sum_firstn l (S i) = x + sum_firstn l i. @@ -89,6 +89,13 @@ Section PseudoMersenneBaseParamProofs. - rewrite IHl by auto; ring. Qed. + Lemma limb_widths_nonneg : forall w, In w limb_widths -> 0 <= w. + Proof. + intros. + apply Z.lt_le_incl. + auto using limb_widths_pos. + Qed. + Lemma sum_firstn_limb_widths_nonneg : forall n, 0 <= sum_firstn limb_widths n. Proof. unfold sum_firstn; intros. @@ -110,7 +117,7 @@ Section PseudoMersenneBaseParamProofs. induction i; intros. + unfold base, sum_firstn, base_from_limb_widths in *; case_eq limb_widths; try reflexivity. intro lw_nil; rewrite lw_nil, (@nil_length0 Z) in *; omega. - + + + assert (i < length base)%nat as lt_i_length by omega. specialize (IHi lt_i_length). rewrite base_length in lt_i_length. @@ -131,7 +138,7 @@ Section PseudoMersenneBaseParamProofs. apply limb_widths_nonneg. eapply nth_error_value_In; eauto. Qed. - + Lemma nth_default_base : forall d i, (i < length base)%nat -> nth_default d base i = 2 ^ (sum_firstn limb_widths i). Proof. @@ -171,7 +178,7 @@ Section PseudoMersenneBaseParamProofs. + rewrite base_length in *; apply limb_widths_match_modulus; assumption. Qed. - Lemma base_succ : forall i, ((S i) < length base)%nat -> + Lemma base_succ : forall i, ((S i) < length base)%nat -> nth_default 0 base (S i) mod nth_default 0 base i = 0. Proof. intros. @@ -219,7 +226,7 @@ Section PseudoMersenneBaseParamProofs. Proof. unfold base; case_eq limb_widths; intros; [pose proof limb_widths_nonnil; congruence | reflexivity]. Qed. - + Lemma base_good : forall i j : nat, (i + j < length base)%nat -> let b := nth_default 0 base in diff --git a/src/ModularArithmetic/PseudoMersenneBaseParams.v b/src/ModularArithmetic/PseudoMersenneBaseParams.v index 3914d6219..e20a7ed09 100644 --- a/src/ModularArithmetic/PseudoMersenneBaseParams.v +++ b/src/ModularArithmetic/PseudoMersenneBaseParams.v @@ -7,7 +7,7 @@ Definition sum_firstn l n := fold_right Z.add 0 (firstn n l). Class PseudoMersenneBaseParams (modulus : Z) := { limb_widths : list Z; - limb_widths_nonneg : forall w, In w limb_widths -> 0 <= w; + limb_widths_pos : forall w, In w limb_widths -> 0 < w; limb_widths_nonnil : limb_widths <> nil; limb_widths_good : forall i j, (i + j < length limb_widths)%nat -> sum_firstn limb_widths (i + j) <= diff --git a/src/ModularArithmetic/PseudoMersenneBaseRep.v b/src/ModularArithmetic/PseudoMersenneBaseRep.v index c16cc8d38..6b4d29a35 100644 --- a/src/ModularArithmetic/PseudoMersenneBaseRep.v +++ b/src/ModularArithmetic/PseudoMersenneBaseRep.v @@ -25,7 +25,7 @@ Class RepZMod (modulus : Z) := { Class SubtractionCoefficient (m : Z) (prm : PseudoMersenneBaseParams m) := { coeff : BaseSystem.digits; - coeff_length : (length coeff <= length PseudoMersenneBaseParamProofs.base)%nat; + coeff_length : (length coeff = length PseudoMersenneBaseParamProofs.base)%nat; coeff_mod: (BaseSystem.decode PseudoMersenneBaseParamProofs.base coeff) mod m = 0 }. @@ -45,6 +45,6 @@ Instance PseudoMersenneBase m (prm : PseudoMersenneBaseParams m) (sc : Subtracti sub := ModularBaseSystem.sub coeff coeff_mod; sub_rep := ModularBaseSystemProofs.sub_rep coeff coeff_mod coeff_length; - mul := ModularBaseSystem.mul; - mul_rep := ModularBaseSystemProofs.mul_rep + mul := ModularBaseSystem.carry_mul; + mul_rep := ModularBaseSystemProofs.carry_mul_rep }. diff --git a/src/ModularArithmetic/Tutorial.v b/src/ModularArithmetic/Tutorial.v index d6c7fa4b8..7d354ab3e 100644 --- a/src/ModularArithmetic/Tutorial.v +++ b/src/ModularArithmetic/Tutorial.v @@ -9,9 +9,9 @@ Section Mod24. (* Specify modulus *) Let q := 24. - + (* Boilerplate for letting Z numbers be interpreted as field elements *) - Local Coercion ZToFq := ZToField : BinNums.Z -> F q. Hint Unfold ZToFq. + Let ZToFq := ZToField : BinNums.Z -> F q. Hint Unfold ZToFq. Local Coercion ZToFq : Z >-> F. (* Boilerplate for [ring]. Similar boilerplate works for [field] if the modulus is prime . *) @@ -21,7 +21,7 @@ Section Mod24. postprocess [Fpostprocess; try exact Fq_1_neq_0; try assumption], constants [Fconstant], div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). + power_tac (@Fpower_theory q) [Fexp_tac]). Lemma sumOfSquares : forall a b: F q, (a+b)^2 = a^2 + 2*a*b + b^2. Proof. @@ -37,9 +37,9 @@ Section Modq. (* Set notations + - * / refer to F operations *) Local Open Scope F_scope. - + (* Boilerplate for letting Z numbers be interpreted as field elements *) - Local Coercion ZToFq := ZToField : BinNums.Z -> F q. Hint Unfold ZToFq. + Let ZToFq := ZToField : BinNums.Z -> F q. Hint Unfold ZToFq. Local Coercion ZToFq : Z >-> F. (* Boilerplate for [field]. Similar boilerplate works for [ring] if the modulus is not prime . *) @@ -49,7 +49,7 @@ Section Modq. postprocess [Fpostprocess; try exact Fq_1_neq_0; try assumption], constants [Fconstant], div (@Fmorph_div_theory q), - power_tac (@Fpower_theory q) [Fexp_tac]). + power_tac (@Fpower_theory q) [Fexp_tac]). Lemma sumOfSquares' : forall a b c: F q, c <> 0 -> ((a+b)/c)^2 = a^2/c^2 + ZToField 2*(a/c)*(b/c) + b^2/c^2. Proof. @@ -170,7 +170,7 @@ Module TimesZeroParametricTestModule (M: PrimeModulus). field; try exact Fq_1_neq_0. Qed. - Lemma biggerFraction : forall XP YP ZP TP XQ YQ ZQ TQ d : F modulus, + Lemma biggerFraction : forall XP YP ZP TP XQ YQ ZQ TQ d : F modulus, ZQ <> 0 -> ZP <> 0 -> ZP * ZQ * ZP * ZQ + d * XP * XQ * YP * YQ <> 0 -> @@ -187,4 +187,3 @@ Module TimesZeroParametricTestModule (M: PrimeModulus). field; assumption. Qed. End TimesZeroParametricTestModule. - diff --git a/src/Rep.v b/src/Rep.v deleted file mode 100644 index b7e7f10c5..000000000 --- a/src/Rep.v +++ /dev/null @@ -1,13 +0,0 @@ -Class RepConversions (T:Type) (RT:Type) : Type := - { - toRep : T -> RT; - unRep : RT -> T - }. - -Definition RepConversionsOK {T RT} (RC:RepConversions T RT) := forall x, unRep (toRep x) = x. - -Definition RepFunOK {T RT} `(RC:RepConversions T RT) (f:T->T) (rf : RT -> RT) := - forall x, f (unRep x) = unRep (rf x). - -Definition RepBinOpOK {T RT} `(RC:RepConversions T RT) (op:T->T->T) (rop : RT -> RT -> RT) := - forall x y, op (unRep x) (unRep y) = unRep (rop x y). diff --git a/src/Spec/CompleteEdwardsCurve.v b/src/Spec/CompleteEdwardsCurve.v index 3348be1d9..06c3f8fdb 100644 --- a/src/Spec/CompleteEdwardsCurve.v +++ b/src/Spec/CompleteEdwardsCurve.v @@ -1,46 +1,45 @@ -Require Coq.ZArith.BinInt Coq.ZArith.Znumtheory. - Require Crypto.CompleteEdwardsCurve.Pre. -Require Import Crypto.Spec.ModularArithmetic. -Local Open Scope F_scope. - -Class TwistedEdwardsParams := { - q : BinInt.Z; - a : F q; - d : F q; - prime_q : Znumtheory.prime q; - two_lt_q : BinInt.Z.lt 2 q; - nonzero_a : a <> 0; - square_a : exists sqrt_a, sqrt_a^2 = a; - nonsquare_d : forall x, x^2 <> d -}. - Module E. Section TwistedEdwardsCurves. - Context {prm:TwistedEdwardsParams}. - (* Twisted Edwards curves with complete addition laws. References: * <https://eprint.iacr.org/2008/013.pdf> * <http://ed25519.cr.yp.to/ed25519-20110926.pdf> * <https://eprint.iacr.org/2015/677.pdf> *) - Definition onCurve P := let '(x,y) := P in a*x^2 + y^2 = 1 + d*x^2*y^2. - Definition point := { P | onCurve P}. - - Definition zero : point := exist _ (0, 1) (@Pre.zeroOnCurve _ _ _ prime_q). - - Definition add' P1' P2' := - let '(x1, y1) := P1' in - let '(x2, y2) := P2' in - (((x1*y2 + y1*x2)/(1 + d*x1*x2*y1*y2)) , ((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2))). - - Definition add (P1 P2 : point) : point := - let 'exist P1' pf1 := P1 in - let 'exist P2' pf2 := P2 in - exist _ (add' P1' P2') - (@Pre.unifiedAdd'_onCurve _ _ _ prime_q two_lt_q nonzero_a square_a nonsquare_d _ _ pf1 pf2). - + + Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} `{Algebra.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}. + Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + Local Notation "0" := Fzero. Local Notation "1" := Fone. + Local Infix "+" := Fadd. Local Infix "*" := Fmul. + Local Infix "-" := Fsub. Local Infix "/" := Fdiv. + Local Notation "x ^2" := (x*x) (at level 30). + + Context {a d: F}. + Class twisted_edwards_params := + { + char_gt_2 : 1 + 1 <> 0; + nonzero_a : a <> 0; + square_a : exists sqrt_a, sqrt_a^2 = a; + nonsquare_d : forall x, x^2 <> d + }. + Context `{twisted_edwards_params}. + + Definition point := { P | let '(x,y) := P in a*x^2 + y^2 = 1 + d*x^2*y^2 }. + Definition coordinates (P:point) : (F*F) := proj1_sig P. + + (** The following points are indeed on the curve -- see [CompleteEdwardsCurve.Pre] for proof *) + Local Obligation Tactic := intros; apply Pre.zeroOnCurve + || apply (Pre.unifiedAdd'_onCurve (char_gt_2:=char_gt_2) (d_nonsquare:=nonsquare_d) + (a_nonzero:=nonzero_a) (a_square:=square_a) _ _ (proj2_sig _) (proj2_sig _)). + + Program Definition zero : point := (0, 1). + + Program Definition add (P1 P2:point) : point := exist _ ( + let (x1, y1) := coordinates P1 in + let (x2, y2) := coordinates P2 in + (((x1*y2 + y1*x2)/(1 + d*x1*x2*y1*y2)) , ((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2)))) _. + Fixpoint mul (n:nat) (P : point) : point := match n with | O => zero @@ -48,7 +47,7 @@ Module E. end. End TwistedEdwardsCurves. End E. - + Delimit Scope E_scope with E. Infix "+" := E.add : E_scope. Infix "*" := E.mul : E_scope.
\ No newline at end of file diff --git a/src/Spec/EdDSA.v b/src/Spec/EdDSA.v index 99f0766e0..d71f2ad44 100644 --- a/src/Spec/EdDSA.v +++ b/src/Spec/EdDSA.v @@ -1,87 +1,80 @@ Require Import Crypto.Spec.Encoding. -Require Import Crypto.Spec.ModularArithmetic. -Require Import Crypto.Spec.CompleteEdwardsCurve. - -Require Import Crypto.Util.WordUtil. -Require Bedrock.Word. +Require Bedrock.Word Crypto.Util.WordUtil. Require Coq.ZArith.Znumtheory Coq.ZArith.BinInt. Require Coq.Numbers.Natural.Peano.NPeano. Require Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Coercion Word.wordToNat : Word.word >-> nat. +Local Infix "^" := NPeano.pow. +Local Infix "mod" := NPeano.modulo (at level 40, no associativity). +Local Infix "++" := Word.combine. + +Generalizable All Variables. +Section EdDSA. + Class EdDSA (* <https://eprint.iacr.org/2015/677.pdf> *) + {E Eeq Eadd Ezero Eopp} {EscalarMult} (* the underllying elliptic curve operations *) -Infix "^" := NPeano.pow. -Infix "mod" := NPeano.modulo. -Infix "++" := Word.combine. + {b : nat} (* public keys are k bits, signatures are 2*k bits *) + {H : forall {n}, Word.word n -> Word.word (b + b)} (* main hash function *) + {c : nat} (* cofactor E = 2^c *) + {n : nat} (* secret keys are (n+1) bits *) + {l : nat} (* order of the subgroup of E generated by B *) -Section EdDSAParams. + {B : E} (* base point *) - Class EdDSAParams := { (* <https://eprint.iacr.org/2015/677.pdf> *) - E : TwistedEdwardsParams; (* underlying elliptic curve *) + {PointEncoding : canonical encoding of E as Word.word b} (* wire format *) + {FlEncoding : canonical encoding of { n | n < l } as Word.word b} + := + { + EdDSA_group:@Algebra.group E Eeq Eadd Ezero Eopp; - b : nat; (* public keys are k bits, signatures are 2*k bits *) - b_valid : 2^(b - 1) > BinInt.Z.to_nat q; - FqEncoding : canonical encoding of F q as Word.word (b-1); - PointEncoding : canonical encoding of E.point as Word.word b; + EdDSA_c_valid : c = 2 \/ c = 3; - H : forall {n}, Word.word n -> Word.word (b + b); (* main hash function *) + EdDSA_n_ge_c : n >= c; + EdDSA_n_le_b : n <= b; - c : nat; (* cofactor E = 2^c *) - c_valid : c = 2 \/ c = 3; + EdDSA_B_not_identity : B <> Ezero; - n : nat; (* secret keys are (n+1) bits *) - n_ge_c : n >= c; - n_le_b : n <= b; + EdDSA_l_prime : Znumtheory.prime (BinInt.Z.of_nat l); + EdDSA_l_odd : l > 2; + EdDSA_l_order_B : EscalarMult l B = Ezero + }. + Global Existing Instance EdDSA_group. - B : E.point; - B_not_identity : B <> E.zero; + Context `{prm:EdDSA}. - l : nat; (* order of the subgroup of E generated by B *) - l_prime : Znumtheory.prime (BinInt.Z.of_nat l); - l_odd : l > 2; - l_order_B : (l*B)%E = E.zero; - FlEncoding : canonical encoding of F (BinInt.Z.of_nat l) as Word.word b - }. -End EdDSAParams. + Local Infix "=" := Eeq. + Local Coercion Word.wordToNat : Word.word >-> nat. + Local Notation secretkey := (Word.word b) (only parsing). + Local Notation publickey := (Word.word b) (only parsing). + Local Notation signature := (Word.word (b + b)) (only parsing). -Section EdDSA. - Context {prm:EdDSAParams}. - Existing Instance E. - Existing Instance PointEncoding. - Existing Instance FlEncoding. - Existing Class le. - Existing Instance n_le_b. - - Notation secretkey := (Word.word b) (only parsing). - Notation publickey := (Word.word b) (only parsing). - Notation signature := (Word.word (b + b)) (only parsing). - Local Infix "==" := CompleteEdwardsCurveTheorems.E.point_eq_dec (at level 70) : E_scope . - - (* TODO: proofread curveKey and definition of n *) - Definition curveKey (sk:secretkey) : nat := - let x := wfirstn n sk in (* first half of the secret key is a scalar *) + Local Arguments H {n} _. + Local Notation wfirstn n w := (@WordUtil.wfirstn n _ w _) (only parsing). + + Require Import Omega. + Obligation Tactic := simpl; intros; try apply NPeano.Nat.mod_upper_bound; destruct prm; omega. + + Program Definition curveKey (sk:secretkey) : nat := + let x := wfirstn n (H sk) in (* hash the key, use first "half" for secret scalar *) let x := x - (x mod (2^c)) in (* it is implicitly 0 mod (2^c) *) x + 2^n. (* and the high bit is always set *) + + Local Infix "+" := Eadd. + Local Infix "*" := EscalarMult. + Definition prngKey (sk:secretkey) : Word.word b := Word.split2 b b (H sk). - Definition public (sk:secretkey) : publickey := enc (curveKey sk * B)%E. + Definition public (sk:secretkey) : publickey := enc (curveKey sk*B). - Definition sign (A_:publickey) sk {n} (M : Word.word n) := + Program Definition sign (A_:publickey) sk {n} (M : Word.word n) := let r : nat := H (prngKey sk ++ M) in (* secret nonce *) - let R : E.point := (r * B)%E in (* commitment to nonce *) + let R : E := r * B in (* commitment to nonce *) let s : nat := curveKey sk in (* secret scalar *) - let S : F (BinInt.Z.of_nat l) := ZToField (BinInt.Z.of_nat - (r + H (enc R ++ public sk ++ M) * s)) in + let S : {n|n<l} := exist _ ((r + H (enc R ++ public sk ++ M) * s) mod l) _ in enc R ++ enc S. - Definition verify (A_:publickey) {n:nat} (M : Word.word n) (sig:signature) : bool := - let R_ := Word.split1 b b sig in - let S_ := Word.split2 b b sig in - match dec S_ : option (F (BinInt.Z.of_nat l)) with None => false | Some S' => - match dec A_ : option E.point with None => false | Some A => - match dec R_ : option E.point with None => false | Some R => - if BinInt.Z.to_nat (FieldToZ S') * B == R + (H (R_ ++ A_ ++ M)) * A - then true else false - end - end - end%E. -End EdDSA.
\ No newline at end of file + (* For a [n]-bit [message] from public key [A_], validity of a signature [R_ ++ S_] *) + Inductive valid {n:nat} : Word.word n -> publickey -> signature -> Prop := + ValidityRule : forall (message:Word.word n) (A:E) (R:E) (S:nat) S_lt_l, + S * B = R + (H (enc R ++ enc A ++ message) mod l) * A + -> valid message (enc A) (enc R ++ enc (exist _ S S_lt_l)). +End EdDSA. diff --git a/src/Spec/ModularArithmetic.v b/src/Spec/ModularArithmetic.v index 76efe3d79..8ee07fe5d 100644 --- a/src/Spec/ModularArithmetic.v +++ b/src/Spec/ModularArithmetic.v @@ -26,8 +26,8 @@ Section FieldOperations. Context {m : BinInt.Z}. (* Coercion without Context {m} --> non-uniform inheritance --> Anomalies *) - Local Coercion ZToFm := ZToField : BinNums.Z -> F m. - + Let ZToFm := ZToField : BinNums.Z -> F m. Local Coercion ZToFm : BinNums.Z >-> F. + Definition add (a b:F m) : F m := ZToField (a + b). Definition mul (a b:F m) : F m := ZToField (a * b). @@ -69,4 +69,4 @@ Infix "-" := sub : F_scope. Infix "/" := div : F_scope. Infix "^" := pow : F_scope. Notation "0" := (ZToField 0) : F_scope. -Notation "1" := (ZToField 1) : F_scope.
\ No newline at end of file +Notation "1" := (ZToField 1) : F_scope. diff --git a/src/Spec/ModularWordEncoding.v b/src/Spec/ModularWordEncoding.v index d6f6bcb3c..acd2bedbd 100644 --- a/src/Spec/ModularWordEncoding.v +++ b/src/Spec/ModularWordEncoding.v @@ -28,7 +28,7 @@ Section ModularWordEncoding. | Word.WS b _ w' => b end. - Instance modular_word_encoding : canonical encoding of F m as word sz := { + Global Instance modular_word_encoding : canonical encoding of F m as word sz := { enc := Fm_enc; dec := Fm_dec; encoding_valid := diff --git a/src/Spec/PointEncoding.v b/src/Spec/PointEncoding.v deleted file mode 100644 index f4634f52f..000000000 --- a/src/Spec/PointEncoding.v +++ /dev/null @@ -1,47 +0,0 @@ -Require Coq.ZArith.ZArith Coq.ZArith.Znumtheory. -Require Coq.Numbers.Natural.Peano.NPeano. -Require Crypto.Encoding.EncodingTheorems. -Require Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Crypto.ModularArithmetic.PrimeFieldTheorems. -Require Bedrock.Word. -Require Crypto.Tactics.VerdiTactics. -Require Crypto.Encoding.PointEncodingPre. -Obligation Tactic := eauto; exact PointEncodingPre.point_encoding_canonical. - -Require Import Crypto.Spec.Encoding Crypto.Spec.ModularWordEncoding. -Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.Spec.ModularArithmetic. - -Local Open Scope F_scope. - -Section PointEncoding. - Context {prm: TwistedEdwardsParams} {sz : nat} {sz_nonzero : (0 < sz)%nat} - {bound_check : (BinInt.Z.to_nat q < NPeano.Nat.pow 2 sz)%nat} {q_5mod8 : (q mod 8 = 5)%Z} - {sqrt_minus1_valid : (@ZToField q 2 ^ BinInt.Z.to_N (q / 4)) ^ 2 = opp 1} - {FqEncoding : canonical encoding of (F q) as (Word.word sz)} - {sign_bit : F q -> bool} {sign_bit_zero : sign_bit 0 = false} - {sign_bit_opp : forall x, x <> 0 -> negb (sign_bit x) = sign_bit (opp x)}. - Existing Instance prime_q. - - Definition point_enc (p : E.point) : Word.word (S sz) := let '(x,y) := proj1_sig p in - Word.WS (sign_bit x) (enc y). - - Program Definition point_dec_with_spec : - {point_dec : Word.word (S sz) -> option E.point - | forall w x, point_dec w = Some x -> (point_enc x = w) - } := @PointEncodingPre.point_dec _ _ _ sign_bit. - - Definition point_dec := Eval hnf in (proj1_sig point_dec_with_spec). - - Definition point_encoding_valid : forall p : E.point, point_dec (point_enc p) = Some p := - @PointEncodingPre.point_encoding_valid _ _ q_5mod8 sqrt_minus1_valid _ _ sign_bit_zero sign_bit_opp. - - Definition point_encoding_canonical : forall x_enc x, point_dec x_enc = Some x -> point_enc x = x_enc := - PointEncodingPre.point_encoding_canonical. - - Instance point_encoding : canonical encoding of E.point as (Word.word (S sz)) := { - enc := point_enc; - dec := point_dec; - encoding_valid := point_encoding_valid; - encoding_canonical := point_encoding_canonical - }. -End PointEncoding.
\ No newline at end of file diff --git a/src/Specific/Ed25519.v b/src/Specific/Ed25519.v deleted file mode 100644 index 3b90b5cdf..000000000 --- a/src/Specific/Ed25519.v +++ /dev/null @@ -1,581 +0,0 @@ -Require Import Bedrock.Word. -Require Import Crypto.Spec.Ed25519. -Require Import Crypto.Tactics.VerdiTactics. -Require Import BinNat BinInt NArith Crypto.Spec.ModularArithmetic. -Require Import ModularArithmetic.ModularArithmeticTheorems. -Require Import ModularArithmetic.PrimeFieldTheorems. -Require Import Crypto.Spec.CompleteEdwardsCurve. -Require Import Crypto.Encoding.PointEncodingPre. -Require Import Crypto.Spec.Encoding Crypto.Spec.ModularWordEncoding Crypto.Spec.PointEncoding. -Require Import Crypto.CompleteEdwardsCurve.ExtendedCoordinates. -Require Import Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems. -Require Import Crypto.Util.IterAssocOp Crypto.Util.WordUtil Crypto.Rep. - -Local Infix "++" := Word.combine. -Local Notation " a '[:' i ']' " := (Word.split1 i _ a) (at level 40). -Local Notation " a '[' i ':]' " := (Word.split2 i _ a) (at level 40). -Local Arguments H {_} _. -Local Arguments scalarMultM1 {_} {_} _ _ _. -Local Arguments unifiedAddM1 {_} {_} _ _. - -Local Ltac set_evars := - repeat match goal with - | [ |- appcontext[?E] ] => is_evar E; let e := fresh "e" in set (e := E) - end. -Local Ltac subst_evars := - repeat match goal with - | [ e := ?E |- _ ] => is_evar E; subst e - end. - -Lemma funexp_proj {T T'} (proj : T -> T') (f : T -> T) (f' : T' -> T') x n - (f_proj : forall a, proj (f a) = f' (proj a)) - : proj (funexp f x n) = funexp f' (proj x) n. -Proof. - revert x; induction n as [|n IHn]; simpl; congruence. -Qed. - -Lemma iter_op_proj {T T' S} (proj : T -> T') (op : T -> T -> T) (op' : T' -> T' -> T') x y z - (testbit : S -> nat -> bool) (bound : nat) - (op_proj : forall a b, proj (op a b) = op' (proj a) (proj b)) - : proj (iter_op op x testbit y z bound) = iter_op op' (proj x) testbit y (proj z) bound. -Proof. - unfold iter_op. - simpl. - lazymatch goal with - | [ |- ?proj (snd (funexp ?f ?x ?n)) = snd (funexp ?f' _ ?n) ] - => pose proof (fun x0 x1 => funexp_proj (fun x => (fst x, proj (snd x))) f f' (x0, x1)) as H' - end. - simpl in H'. - rewrite <- H'. - { reflexivity. } - { intros [??]; simpl. - repeat match goal with - | [ |- context[match ?n with _ => _ end] ] - => destruct n eqn:? - | _ => progress simpl - | _ => progress subst - | _ => reflexivity - | _ => rewrite op_proj - end. } -Qed. - -Lemma B_proj : proj1_sig B = (fst(proj1_sig B), snd(proj1_sig B)). destruct B as [[]]; reflexivity. Qed. - -Require Import Coq.Setoids.Setoid. -Require Import Coq.Classes.Morphisms. -Global Instance option_rect_Proper_nd {A T} - : Proper ((pointwise_relation _ eq) ==> eq ==> eq ==> eq) (@option_rect A (fun _ => T)). -Proof. - intros ?? H ??? [|]??; subst; simpl; congruence. -Qed. - -Global Instance option_rect_Proper_nd' {A T} - : Proper ((pointwise_relation _ eq) ==> eq ==> forall_relation (fun _ => eq)) (@option_rect A (fun _ => T)). -Proof. - intros ?? H ??? [|]; subst; simpl; congruence. -Qed. - -Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?T))) => exact (@option_rect_Proper_nd' A T) : typeclass_instances. - -Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v, - option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v). -Proof. - destruct v; reflexivity. -Qed. - -Axiom decode_scalar : word b -> option N. -Local Existing Instance Ed25519.FlEncoding. -Axiom decode_scalar_correct : forall x, decode_scalar x = option_map (fun x : F (Z.of_nat Ed25519.l) => Z.to_N x) (dec x). - -Local Infix "==?" := E.point_eqb (at level 70) : E_scope. -Local Infix "==?" := ModularArithmeticTheorems.F_eq_dec (at level 70) : F_scope. - -Lemma solve_for_R_eq : forall A B C, (A = B + C <-> B = A - C)%E. -Proof. - intros; split; intros; subst; unfold E.sub; - rewrite <-E.add_assoc, ?E.add_opp_r, ?E.add_opp_l, E.add_0_r; reflexivity. -Qed. - -Lemma solve_for_R : forall A B C, (A ==? B + C)%E = (B ==? A - C)%E. -Proof. - intros. - repeat match goal with |- context [(?P ==? ?Q)%E] => - let H := fresh "H" in - destruct (E.point_eq_dec P Q) as [H|H]; - (rewrite (E.point_eqb_complete _ _ H) || rewrite (E.point_eqb_neq_complete _ _ H)) - end; rewrite solve_for_R_eq in H; congruence. -Qed. - -Local Notation "'(' X ',' Y ',' Z ',' T ')'" := (mkExtended X Y Z T). -Local Notation "2" := (ZToField 2) : F_scope. - -Local Existing Instance PointEncoding. -Lemma decode_point_eq : forall (P_ Q_ : word (S (b-1))) (P Q:E.point), - dec P_ = Some P -> - dec Q_ = Some Q -> - weqb P_ Q_ = (P ==? Q)%E. -Proof. - intros. - replace P_ with (enc P) in * by (auto using encoding_canonical). - replace Q_ with (enc Q) in * by (auto using encoding_canonical). - rewrite E.point_eqb_correct. - edestruct E.point_eq_dec; (apply weqb_true_iff || apply weqb_false_iff); congruence. -Qed. - -Lemma decode_test_encode_test : forall S_ X, option_rect (fun _ : option E.point => bool) - (fun S : E.point => (S ==? X)%E) false (dec S_) = weqb S_ (enc X). -Proof. - intros. - destruct (dec S_) eqn:H. - { symmetry; eauto using decode_point_eq, encoding_valid. } - { simpl @option_rect. - destruct (weqb S_ (enc X)) eqn:Heqb; trivial. - apply weqb_true_iff in Heqb. subst. rewrite encoding_valid in H; discriminate. } -Qed. - -Definition enc' : F q * F q -> word b. -Proof. - intro x. - let enc' := (eval hnf in (@enc (@E.point curve25519params) _ _)) in - match (eval cbv [proj1_sig] in (fun pf => enc' (exist _ x pf))) with - | (fun _ => ?enc') => exact enc' - end. -Defined. - -Definition enc'_correct : @enc (@E.point curve25519params) _ _ = (fun x => enc' (proj1_sig x)) - := eq_refl. - -Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y. -Global Instance Let_In_Proper_nd {A P} - : Proper (eq ==> pointwise_relation _ eq ==> eq) (@Let_In A (fun _ => P)). -Proof. - lazy; intros; congruence. -Qed. -Lemma option_rect_function {A B C S' N' v} f - : f (option_rect (fun _ : option A => option B) S' N' v) - = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v. -Proof. destruct v; reflexivity. Qed. -Local Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *) - idtac; - lazymatch goal with - | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ] - => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *) - cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta; - [ set_evars; - let H := fresh in - intro H; - rewrite H; - clear; - abstract (cbv [Let_In]; reflexivity) - | ] - end. -Local Ltac replace_let_in_with_Let_In := - repeat match goal with - | [ |- context G[let x := ?y in @?z x] ] - => let G' := context G[Let_In y z] in change G' - | [ |- _ = Let_In _ _ ] - => apply Let_In_Proper_nd; [ reflexivity | cbv beta delta [pointwise_relation]; intro ] - end. -Local Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *) - repeat match goal with - | [ |- context[option_rect ?P ?S ?N None] ] - => change (option_rect P S N None) with N - | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ] - => change (option_rect P S N (Some x)) with (S x); cbv beta - end. - -Section Ed25519Frep. - Generalizable All Variables. - Context `(rcS:RepConversions N SRep) (rcSOK:RepConversionsOK rcS). - Context `(rcF:RepConversions (F (Ed25519.q)) FRep) (rcFOK:RepConversionsOK rcF). - Context (FRepAdd FRepSub FRepMul:FRep->FRep->FRep) (FRepAdd_correct:RepBinOpOK rcF add FRepMul). - Context (FRepSub_correct:RepBinOpOK rcF sub FRepSub) (FRepMul_correct:RepBinOpOK rcF mul FRepMul). - Local Notation rep2F := (unRep : FRep -> F (Ed25519.q)). - Local Notation F2Rep := (toRep : F (Ed25519.q) -> FRep). - Local Notation rep2S := (unRep : SRep -> N). - Local Notation S2Rep := (toRep : N -> SRep). - - Axiom FRepOpp : FRep -> FRep. - Axiom FRepOpp_correct : forall x, opp (rep2F x) = rep2F (FRepOpp x). - - Axiom wltu : forall {b}, word b -> word b -> bool. - Axiom wltu_correct : forall {b} (x y:word b), wltu x y = (wordToN x <? wordToN y)%N. - - Axiom compare_enc : forall x y, F_eqb x y = weqb (@enc _ _ FqEncoding x) (@enc _ _ FqEncoding y). - - Axiom wire2FRep : word (b-1) -> option FRep. - Axiom wire2FRep_correct : forall x, Fm_dec x = option_map rep2F (wire2FRep x). - - Axiom FRep2wire : FRep -> word (b-1). - Axiom FRep2wire_correct : forall x, FRep2wire x = @enc _ _ FqEncoding (rep2F x). - - Axiom SRep_testbit : SRep -> nat -> bool. - Axiom SRep_testbit_correct : forall (x0 : SRep) (i : nat), SRep_testbit x0 i = N.testbit_nat (unRep x0) i. - - Definition FSRepPow x n := iter_op FRepMul (toRep 1%F) SRep_testbit n x 255. - Lemma FSRepPow_correct : forall x n, (N.size_nat (unRep n) <= 255)%nat -> (unRep x ^ unRep n)%F = unRep (FSRepPow x n). - Proof. (* this proof derives the required formula, which I copy-pasted above to be able to reference it without the length precondition *) - unfold FSRepPow; intros. - erewrite <-pow_nat_iter_op_correct by auto. - erewrite <-(fun x => iter_op_spec (scalar := SRep) (mul (m:=Ed25519.q)) F_mul_assoc _ F_mul_1_l _ unRep SRep_testbit_correct n x 255%nat) by auto. - rewrite <-(rcFOK 1%F) at 1. - erewrite <-iter_op_proj by auto. - reflexivity. - Qed. - - Definition FRepInv x : FRep := FSRepPow x (S2Rep (Z.to_N (Ed25519.q - 2))). - Lemma FRepInv_correct : forall x, inv (rep2F x)%F = rep2F (FRepInv x). - unfold FRepInv; intros. - rewrite <-FSRepPow_correct; rewrite rcSOK; try reflexivity. - pose proof @Fq_inv_fermat_correct as H; unfold inv_fermat in H; rewrite H by - auto using Ed25519.prime_q, Ed25519.two_lt_q. - reflexivity. - Qed. - - Lemma unfoldDiv : forall {m} (x y:F m), (x/y = x * inv y)%F. Proof. unfold div. congruence. Qed. - - Definition rep2E (r:FRep * FRep * FRep * FRep) : extended := - match r with (((x, y), z), t) => mkExtended (rep2F x) (rep2F y) (rep2F z) (rep2F t) end. - - Lemma if_map : forall {T U} (f:T->U) (b:bool) (x y:T), (if b then f x else f y) = f (if b then x else y). - Proof. - destruct b; trivial. - Qed. - - Local Ltac Let_In_unRep := - match goal with - | [ |- appcontext G[Let_In (unRep ?x) ?f] ] - => change (Let_In (unRep x) f) with (Let_In x (fun y => f (unRep y))); cbv beta - end. - - - (** TODO: Move me *) - Lemma pull_Let_In {B C} (f : B -> C) A (v : A) (b : A -> B) - : Let_In v (fun v' => f (b v')) = f (Let_In v b). - Proof. - reflexivity. - Qed. - - Lemma Let_app_In {A B T} (g:A->B) (f:B->T) (x:A) : - @Let_In _ (fun _ => T) (g x) f = - @Let_In _ (fun _ => T) x (fun p => f (g x)). - Proof. reflexivity. Qed. - - Lemma Let_app2_In {A B C D T} (g1:A->C) (g2:B->D) (f:C*D->T) (x:A) (y:B) : - @Let_In _ (fun _ => T) (g1 x, g2 y) f = - @Let_In _ (fun _ => T) (x, y) (fun p => f ((g1 (fst p), g2 (snd p)))). - Proof. reflexivity. Qed. - - Create HintDb FRepOperations discriminated. - Hint Rewrite FRepMul_correct FRepAdd_correct FRepSub_correct FRepInv_correct FSRepPow_correct FRepOpp_correct : FRepOperations. - - Create HintDb EdDSA_opts discriminated. - Hint Rewrite FRepMul_correct FRepAdd_correct FRepSub_correct FRepInv_correct FSRepPow_correct FRepOpp_correct : EdDSA_opts. - - Lemma unifiedAddM1Rep_sig : forall a b : FRep * FRep * FRep * FRep, { unifiedAddM1Rep | rep2E unifiedAddM1Rep = unifiedAddM1' (rep2E a) (rep2E b) }. - Proof. - destruct a as [[[]]]; destruct b as [[[]]]. - eexists. - lazymatch goal with |- ?LHS = ?RHS :> ?T => - evar (e:T); replace LHS with e; [subst e|] - end. - unfold rep2E. cbv beta delta [unifiedAddM1']. - pose proof (rcFOK twice_d) as H; rewrite <-H; clear H. (* XXX: this is a hack -- rewrite misresolves typeclasses? *) - - { etransitivity; [|replace_let_in_with_Let_In; reflexivity]. - repeat ( - autorewrite with FRepOperations; - Let_In_unRep; - eapply Let_In_Proper_nd; [reflexivity|cbv beta delta [Proper respectful pointwise_relation]; intro]). - lazymatch goal with |- ?LHS = (unRep ?x, unRep ?y, unRep ?z, unRep ?t) => - change (LHS = (rep2E (((x, y), z), t))) - end. - reflexivity. } - - subst e. - Local Opaque Let_In. - repeat setoid_rewrite (pull_Let_In rep2E). - Local Transparent Let_In. - reflexivity. - Defined. - - Definition unifiedAddM1Rep (a b:FRep * FRep * FRep * FRep) : FRep * FRep * FRep * FRep := Eval hnf in proj1_sig (unifiedAddM1Rep_sig a b). - Definition unifiedAddM1Rep_correct a b : rep2E (unifiedAddM1Rep a b) = unifiedAddM1' (rep2E a) (rep2E b) := Eval hnf in proj2_sig (unifiedAddM1Rep_sig a b). - - Definition rep2T (P:FRep * FRep) := (rep2F (fst P), rep2F (snd P)). - Definition erep2trep (P:FRep * FRep * FRep * FRep) := Let_In P (fun P => Let_In (FRepInv (snd (fst P))) (fun iZ => (FRepMul (fst (fst (fst P))) iZ, FRepMul (snd (fst (fst P))) iZ))). - Lemma erep2trep_correct : forall P, rep2T (erep2trep P) = extendedToTwisted (rep2E P). - Proof. - unfold rep2T, rep2E, erep2trep, extendedToTwisted; destruct P as [[[]]]; simpl. - rewrite !unfoldDiv, <-!FRepMul_correct, <-FRepInv_correct. reflexivity. - Qed. - - (** TODO: possibly move me, remove local *) - Local Ltac replace_option_match_with_option_rect := - idtac; - lazymatch goal with - | [ |- _ = ?RHS :> ?T ] - => lazymatch RHS with - | match ?a with None => ?N | Some x => @?S x end - => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity) - end - end. - - (** TODO: Move me, remove Local *) - Definition proj1_sig_unmatched {A P} := @proj1_sig A P. - Definition proj1_sig_nounfold {A P} := @proj1_sig A P. - Definition proj1_sig_unfold {A P} := Eval cbv [proj1_sig] in @proj1_sig A P. - Local Ltac unfold_proj1_sig_exist := - (** Change the first [proj1_sig] into [proj1_sig_unmatched]; if it's applied to [exist], mark it as unfoldable, otherwise mark it as not unfoldable. Then repeat. Finally, unfold. *) - repeat (change @proj1_sig with @proj1_sig_unmatched at 1; - match goal with - | [ |- context[proj1_sig_unmatched (exist _ _ _)] ] - => change @proj1_sig_unmatched with @proj1_sig_unfold - | _ => change @proj1_sig_unmatched with @proj1_sig_nounfold - end); - (* [proj1_sig_nounfold] is a thin wrapper around [proj1_sig]; unfolding it restores [proj1_sig]. Unfolding [proj1_sig_nounfold] exposes the pattern match, which is reduced by ι. *) - cbv [proj1_sig_nounfold proj1_sig_unfold]. - - (** TODO: possibly move me, remove Local *) - Local Ltac reflexivity_when_unification_is_stupid_about_evars - := repeat first [ reflexivity - | apply f_equal ]. - - - Local Existing Instance eq_Reflexive. (* To get some of the [setoid_rewrite]s below to work, we need to infer [Reflexive eq] before [Reflexive Equivalence.equiv] *) - - (* TODO: move me *) - Lemma fold_rep2E x y z t - : (rep2F x, rep2F y, rep2F z, rep2F t) = rep2E (((x, y), z), t). - Proof. reflexivity. Qed. - Lemma commute_negateExtended'_rep2E x y z t - : negateExtended' (rep2E (((x, y), z), t)) - = rep2E (((FRepOpp x, y), z), FRepOpp t). - Proof. simpl; autorewrite with FRepOperations; reflexivity. Qed. - Lemma fold_rep2E_ffff x y z t - : (x, y, z, t) = rep2E (((toRep x, toRep y), toRep z), toRep t). - Proof. simpl; rewrite !rcFOK; reflexivity. Qed. - Lemma fold_rep2E_rrfr x y z t - : (rep2F x, rep2F y, z, rep2F t) = rep2E (((x, y), toRep z), t). - Proof. simpl; rewrite !rcFOK; reflexivity. Qed. - Lemma fold_rep2E_0fff y z t - : (0%F, y, z, t) = rep2E (((toRep 0%F, toRep y), toRep z), toRep t). - Proof. apply fold_rep2E_ffff. Qed. - Lemma fold_rep2E_ff1f x y t - : (x, y, 1%F, t) = rep2E (((toRep x, toRep y), toRep 1%F), toRep t). - Proof. apply fold_rep2E_ffff. Qed. - Lemma commute_negateExtended'_rep2E_rrfr x y z t - : negateExtended' (unRep x, unRep y, z, unRep t) - = rep2E (((FRepOpp x, y), toRep z), FRepOpp t). - Proof. rewrite <- commute_negateExtended'_rep2E; simpl; rewrite !rcFOK; reflexivity. Qed. - - Hint Rewrite @F_mul_0_l commute_negateExtended'_rep2E_rrfr fold_rep2E_0fff (@fold_rep2E_ff1f (fst (proj1_sig B))) @if_F_eq_dec_if_F_eqb compare_enc (if_map unRep) (fun T => Let_app2_In (T := T) unRep unRep) @F_pow_2_r @unfoldDiv : EdDSA_opts. - Hint Rewrite <- unifiedAddM1Rep_correct erep2trep_correct (fun x y z bound => iter_op_proj rep2E unifiedAddM1Rep unifiedAddM1' x y z N.testbit_nat bound unifiedAddM1Rep_correct) FRep2wire_correct: EdDSA_opts. - - Lemma sharper_verify : forall pk l msg sig, { verify | verify = ed25519_verify pk l msg sig}. - Proof. - eexists; intros. - cbv [ed25519_verify EdDSA.verify - ed25519params curve25519params - EdDSA.E EdDSA.B EdDSA.b EdDSA.l EdDSA.H - EdDSA.PointEncoding EdDSA.FlEncoding EdDSA.FqEncoding]. - - etransitivity. - Focus 2. - { repeat match goal with - | [ |- ?x = ?x ] => reflexivity - | _ => replace_option_match_with_option_rect - | [ |- _ = option_rect _ _ _ _ ] - => eapply option_rect_Proper_nd; [ intro | reflexivity.. ] - end. - set_evars. - rewrite<- E.point_eqb_correct. - rewrite solve_for_R; unfold E.sub. - rewrite E.opp_mul. - let p1 := constr:(scalarMultM1_rep eq_refl) in - let p2 := constr:(unifiedAddM1_rep eq_refl) in - repeat match goal with - | |- context [(_ * E.opp ?P)%E] => - rewrite <-(unExtendedPoint_mkExtendedPoint P); - rewrite negateExtended_correct; - rewrite <-p1 - | |- context [(_ * ?P)%E] => - rewrite <-(unExtendedPoint_mkExtendedPoint P); - rewrite <-p1 - | _ => rewrite p2 - end; - rewrite ?Znat.Z_nat_N, <-?Word.wordToN_nat; - subst_evars; - reflexivity. - } Unfocus. - - etransitivity. - Focus 2. - { lazymatch goal with |- _ = option_rect _ _ ?false ?dec => - symmetry; etransitivity; [|eapply (option_rect_option_map (fun (x:F _) => Z.to_N x) _ false dec)] - end. - eapply option_rect_Proper_nd; [intro|reflexivity..]. - match goal with - | [ |- ?RHS = ?e ?v ] - => let RHS' := (match eval pattern v in RHS with ?RHS' _ => RHS' end) in - unify e RHS' - end. - reflexivity. - } Unfocus. - rewrite <-decode_scalar_correct. - - etransitivity. - Focus 2. - { do 2 (eapply option_rect_Proper_nd; [intro|reflexivity..]). - symmetry; apply decode_test_encode_test. - } Unfocus. - - rewrite enc'_correct. - cbv [unExtendedPoint unifiedAddM1 negateExtended scalarMultM1]. - unfold_proj1_sig_exist. - - etransitivity. - Focus 2. - { do 2 (eapply option_rect_Proper_nd; [intro|reflexivity..]). - set_evars. - repeat match goal with - | [ |- appcontext[@proj1_sig ?A ?P (@iter_op ?T ?f ?neutral ?T' ?testbit ?exp ?base ?bound)] ] - => erewrite (@iter_op_proj T _ _ (@proj1_sig _ _)) by reflexivity - end. - subst_evars. - reflexivity. } - Unfocus. - - cbv [mkExtendedPoint E.zero]. - unfold_proj1_sig_exist. - rewrite B_proj. - - etransitivity. - Focus 2. - { do 1 (eapply option_rect_Proper_nd; [intro|reflexivity..]). - set_evars. - lazymatch goal with |- _ = option_rect _ _ ?false ?dec => - symmetry; etransitivity; [|eapply (option_rect_option_map (@proj1_sig _ _) _ false dec)] - end. - eapply option_rect_Proper_nd; [intro|reflexivity..]. - match goal with - | [ |- ?RHS = ?e ?v ] - => let RHS' := (match eval pattern v in RHS with ?RHS' _ => RHS' end) in - unify e RHS' - end. - reflexivity. - } Unfocus. - - cbv [dec PointEncoding point_encoding]. - etransitivity. - Focus 2. - { do 1 (eapply option_rect_Proper_nd; [intro|reflexivity..]). - etransitivity. - Focus 2. - { apply f_equal. - symmetry. - apply point_dec_coordinates_correct. } - Unfocus. - reflexivity. } - Unfocus. - - cbv iota beta delta [point_dec_coordinates sign_bit dec FqEncoding modular_word_encoding E.solve_for_x2 sqrt_mod_q]. - - etransitivity. - Focus 2. { - do 1 (eapply option_rect_Proper_nd; [|reflexivity..]). cbv beta delta [pointwise_relation]. intro. - etransitivity. - Focus 2. - { apply f_equal. - lazymatch goal with - | [ |- _ = ?term :> ?T ] - => lazymatch term with (match ?a with None => ?N | Some x => @?S x end) - => let term' := constr:((option_rect (fun _ => T) S N) a) in - replace term with term' by reflexivity - end - end. - reflexivity. } Unfocus. reflexivity. } Unfocus. - - etransitivity. - Focus 2. { - do 1 (eapply option_rect_Proper_nd; [cbv beta delta [pointwise_relation]; intro|reflexivity..]). - do 1 (eapply option_rect_Proper_nd; [ intro; reflexivity | reflexivity | ]). - eapply option_rect_Proper_nd; [ cbv beta delta [pointwise_relation]; intro | reflexivity.. ]. - replace_let_in_with_Let_In. - reflexivity. - } Unfocus. - - etransitivity. - Focus 2. { - do 1 (eapply option_rect_Proper_nd; [cbv beta delta [pointwise_relation]; intro|reflexivity..]). - set_evars. - rewrite option_rect_function. (* turn the two option_rects into one *) - subst_evars. - simpl_option_rect. - do 1 (eapply option_rect_Proper_nd; [cbv beta delta [pointwise_relation]; intro|reflexivity..]). - (* push the [option_rect] inside until it hits a [Some] or a [None] *) - repeat match goal with - | _ => commute_option_rect_Let_In - | [ |- _ = Let_In _ _ ] - => apply Let_In_Proper_nd; [ reflexivity | cbv beta delta [pointwise_relation]; intro ] - | [ |- ?LHS = option_rect ?P ?S ?N (if ?b then ?t else ?f) ] - => transitivity (if b then option_rect P S N t else option_rect P S N f); - [ - | destruct b; reflexivity ] - | [ |- _ = if ?b then ?t else ?f ] - => apply (f_equal2 (fun x y => if b then x else y)) - | [ |- _ = false ] => reflexivity - | _ => progress simpl_option_rect - end. - reflexivity. - } Unfocus. - - cbv iota beta delta [q d a]. - - rewrite wire2FRep_correct. - - etransitivity. - Focus 2. { - eapply option_rect_Proper_nd; [|reflexivity..]. cbv beta delta [pointwise_relation]. intro. - rewrite <-!(option_rect_option_map rep2F). - eapply option_rect_Proper_nd; [|reflexivity..]. cbv beta delta [pointwise_relation]. intro. - autorewrite with EdDSA_opts. - rewrite <-(rcFOK 1%F). - pattern Ed25519.d at 1. rewrite <-(rcFOK Ed25519.d) at 1. - pattern Ed25519.a at 1. rewrite <-(rcFOK Ed25519.a) at 1. - rewrite <- (rcSOK (Z.to_N (Ed25519.q / 8 + 1))). - autorewrite with EdDSA_opts. - (Let_In_unRep). - eapply Let_In_Proper_nd; [reflexivity|cbv beta delta [pointwise_relation]; intro]. - etransitivity. Focus 2. eapply Let_In_Proper_nd; [|cbv beta delta [pointwise_relation]; intro;reflexivity]. { - rewrite FSRepPow_correct by (rewrite rcSOK; cbv; omega). - (Let_In_unRep). - etransitivity. Focus 2. eapply Let_In_Proper_nd; [reflexivity|cbv beta delta [pointwise_relation]; intro]. { - set_evars. - rewrite <-(rcFOK sqrt_minus1). - autorewrite with EdDSA_opts. - subst_evars. - reflexivity. } Unfocus. - rewrite pull_Let_In. - reflexivity. } Unfocus. - set_evars. - (Let_In_unRep). - - subst_evars. eapply Let_In_Proper_nd; [reflexivity|cbv beta delta [pointwise_relation]; intro]. set_evars. - - autorewrite with EdDSA_opts. - - subst_evars. - lazymatch goal with |- _ = if ?b then ?t else ?f => apply (f_equal2 (fun x y => if b then x else y)) end; [|reflexivity]. - eapply Let_In_Proper_nd; [reflexivity|cbv beta delta [pointwise_relation]; intro]. - set_evars. - - unfold twistedToExtended. - autorewrite with EdDSA_opts. - progress cbv beta delta [erep2trep]. - - subst_evars. - reflexivity. } Unfocus. - reflexivity. - Defined. -End Ed25519Frep.
\ No newline at end of file diff --git a/src/Specific/GF1305.v b/src/Specific/GF1305.v index b004a60d1..02ef714d9 100644 --- a/src/Specific/GF1305.v +++ b/src/Specific/GF1305.v @@ -15,6 +15,7 @@ Local Open Scope Z. Definition modulus : Z := 2^130 - 5. Lemma prime_modulus : prime modulus. Admitted. +Definition int_width := 32%Z. Instance params1305 : PseudoMersenneBaseParams modulus. construct_params prime_modulus 5%nat 130. @@ -26,16 +27,22 @@ Instance subCoeff : SubtractionCoefficient modulus params1305. apply Build_SubtractionCoefficient with (coeff := mul2modulus); cbv; auto. Defined. +Definition freezePreconditions1305 : freezePreconditions params1305 int_width. +Proof. + constructor; compute_preconditions. +Defined. + (* END PseudoMersenneBaseParams instance construction. *) (* Precompute k and c *) Definition k_ := Eval compute in k. Definition c_ := Eval compute in c. +Definition c_subst : c = c_ := eq_refl c_. (* Makes Qed not take forever *) Opaque Z.shiftr Pos.iter Z.div2 Pos.div2 Pos.div2_up Pos.succ Z.land Z.of_N Pos.land N.ldiff Pos.pred_N Pos.pred_double Z.opp Z.mul Pos.mul - Let_In digits Z.add Pos.add Z.pos_sub. + Let_In digits Z.add Pos.add Z.pos_sub andb Z.eqb Z.ltb. Local Open Scope nat_scope. Lemma GF1305Base26_mul_reduce_formula : @@ -45,8 +52,9 @@ Lemma GF1305Base26_mul_reduce_formula : -> rep ls (f*g)%F}. Proof. eexists; intros ? ? Hf Hg. - pose proof (carry_mul_opt_correct k_ c_ (eq_refl k) (eq_refl c_) [0;4;3;2;1;0]_ _ _ _ Hf Hg) as Hfg. + pose proof (carry_mul_opt_rep k_ c_ (eq_refl k) c_subst _ _ _ _ Hf Hg) as Hfg. compute_formula. + exact Hfg. Defined. Lemma GF1305Base26_add_formula : @@ -58,17 +66,30 @@ Proof. eexists; intros ? ? Hf Hg. pose proof (add_opt_rep _ _ _ _ Hf Hg) as Hfg. compute_formula. + exact Hfg. Defined. -Lemma GF25519Base25Point5_sub_formula : - forall f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 - g0 g1 g2 g3 g4 g5 g6 g7 g8 g9, - {ls | forall f g, rep [f0;f1;f2;f3;f4;f5;f6;f7;f8;f9] f - -> rep [g0;g1;g2;g3;g4;g5;g6;g7;g8;g9] g +Lemma GF1305Base26_sub_formula : + forall f0 f1 f2 f3 f4 g0 g1 g2 g3 g4, + {ls | forall f g, rep [f0;f1;f2;f3;f4] f + -> rep [g0;g1;g2;g3;g4] g -> rep ls (f - g)%F}. Proof. eexists. intros f g Hf Hg. pose proof (sub_opt_rep _ _ _ _ Hf Hg) as Hfg. compute_formula. -Defined.
\ No newline at end of file + exact Hfg. +Defined. + +Lemma GF1305Base26_freeze_formula : + forall f0 f1 f2 f3 f4, + {ls | forall x, rep [f0;f1;f2;f3;f4] x + -> rep ls x}. +Proof. + eexists. + intros x Hf. + pose proof (freeze_opt_preserves_rep _ c_subst freezePreconditions1305 _ _ Hf) as Hfreeze_rep. + compute_formula. + exact Hfreeze_rep. +Defined. diff --git a/src/Specific/GF25519.v b/src/Specific/GF25519.v index 8aaf8caf6..471c1d548 100644 --- a/src/Specific/GF25519.v +++ b/src/Specific/GF25519.v @@ -7,7 +7,6 @@ Require Import Coq.Lists.List Crypto.Util.ListUtil. Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. Require Import Crypto.Tactics.VerdiTactics. Require Import Crypto.BaseSystem. -Require Import Crypto.Rep. Import ListNotations. Require Import Coq.ZArith.ZArith Coq.ZArith.Zpower Coq.ZArith.ZArith Coq.ZArith.Znumtheory. Local Open Scope Z. @@ -16,6 +15,7 @@ Local Open Scope Z. Definition modulus : Z := 2^255 - 19. Lemma prime_modulus : prime modulus. Admitted. +Definition int_width := 32%Z. Instance params25519 : PseudoMersenneBaseParams modulus. construct_params prime_modulus 10%nat 255. @@ -27,16 +27,22 @@ Instance subCoeff : SubtractionCoefficient modulus params25519. apply Build_SubtractionCoefficient with (coeff := mul2modulus); cbv; auto. Defined. +Definition freezePreconditions25519 : freezePreconditions params25519 int_width. +Proof. + constructor; compute_preconditions. +Defined. + (* END PseudoMersenneBaseParams instance construction. *) (* Precompute k and c *) Definition k_ := Eval compute in k. Definition c_ := Eval compute in c. +Definition c_subst : c = c_ := eq_refl c_. (* Makes Qed not take forever *) Opaque Z.shiftr Pos.iter Z.div2 Pos.div2 Pos.div2_up Pos.succ Z.land Z.of_N Pos.land N.ldiff Pos.pred_N Pos.pred_double Z.opp Z.mul Pos.mul - Let_In digits Z.add Pos.add Z.pos_sub. + Let_In digits Z.add Pos.add Z.pos_sub andb Z.eqb Z.ltb. Local Open Scope nat_scope. Lemma GF25519Base25Point5_mul_reduce_formula : @@ -47,9 +53,23 @@ Lemma GF25519Base25Point5_mul_reduce_formula : -> rep ls (f*g)%F}. Proof. eexists; intros ? ? Hf Hg. - pose proof (carry_mul_opt_correct k_ c_ (eq_refl k_) (eq_refl c_) [0;9;8;7;6;5;4;3;2;1;0]_ _ _ _ Hf Hg) as Hfg. + pose proof (carry_mul_opt_rep k_ c_ (eq_refl k_) c_subst _ _ _ _ Hf Hg) as Hfg. compute_formula. -Time Defined. + exact Hfg. +(*Time*) Defined. + +(* Uncomment this to see a pretty-printed mulmod +Local Transparent Let_In. +Infix "<<" := Z.shiftr (at level 50). +Infix "&" := Z.land (at level 50). +Eval cbv beta iota delta [proj1_sig GF25519Base25Point5_mul_reduce_formula Let_In] in + fun f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 + g0 g1 g2 g3 g4 g5 g6 g7 g8 g9 => proj1_sig ( + GF25519Base25Point5_mul_reduce_formula f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 + g0 g1 g2 g3 g4 g5 g6 g7 g8 g9). +Local Opaque Let_In. +*) + Extraction "/tmp/test.ml" GF25519Base25Point5_mul_reduce_formula. (* It's easy enough to use extraction to get the proper nice-looking formula. @@ -69,6 +89,7 @@ Proof. intros f g Hf Hg. pose proof (add_opt_rep _ _ _ _ Hf Hg) as Hfg. compute_formula. + exact Hfg. Defined. Lemma GF25519Base25Point5_sub_formula : @@ -82,99 +103,28 @@ Proof. intros f g Hf Hg. pose proof (sub_opt_rep _ _ _ _ Hf Hg) as Hfg. compute_formula. + exact Hfg. Defined. -Definition F25519Rep := (Z * Z * Z * Z * Z * Z * Z * Z * Z * Z)%type. - -Definition F25519toRep (x:F (2^255 - 19)) : F25519Rep := (0, 0, 0, 0, 0, 0, 0, 0, 0, FieldToZ x)%Z. -Definition F25519unRep (rx:F25519Rep) := - let '(x9, x8, x7, x6, x5, x4, x3, x2, x1, x0) := rx in - ModularBaseSystem.decode [x0;x1;x2;x3;x4;x5;x6;x7;x8;x9]. - -Global Instance F25519RepConversions : RepConversions (F (2^255 - 19)) F25519Rep := - { - toRep := F25519toRep; - unRep := F25519unRep - }. - -Lemma F25519RepConversionsOK : RepConversionsOK F25519RepConversions. +Lemma GF25519Base25Point5_freeze_formula : + forall f0 f1 f2 f3 f4 f5 f6 f7 f8 f9, + {ls | forall x, rep [f0;f1;f2;f3;f4;f5;f6;f7;f8;f9] x + -> rep ls x}. Proof. - unfold F25519RepConversions, RepConversionsOK, unRep, toRep, F25519toRep, F25519unRep; intros. - change (ModularBaseSystem.decode (ModularBaseSystem.encode x) = x). - eauto using ModularBaseSystemProofs.rep_decode, ModularBaseSystemProofs.encode_rep. -Qed. - -Definition F25519Rep_mul (f g:F25519Rep) : F25519Rep. - refine ( - let '(f9, f8, f7, f6, f5, f4, f3, f2, f1, f0) := f in - let '(g9, g8, g7, g6, g5, g4, g3, g2, g1, g0) := g in _). - (* FIXME: the r should not be present in generated code *) - pose (r := proj1_sig (GF25519Base25Point5_mul_reduce_formula f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 - g0 g1 g2 g3 g4 g5 g6 g7 g8 g9)). - simpl in r. - unfold F25519Rep. - repeat let t' := (eval cbv beta delta [r] in r) in - lazymatch t' with Let_In ?arg ?f => - let x := fresh "x" in - refine (let x := arg in _); - let t'' := (eval cbv beta in (f x)) in - change (Let_In arg f) with t'' in r - end. - let t' := (eval cbv beta delta [r] in r) in - lazymatch t' with [?r0;?r1;?r2;?r3;?r4;?r5;?r6;?r7;?r8;?r9] => - clear r; - exact (r9, r8, r7, r6, r5, r4, r3, r2, r1, r0) - end. -Time Defined. - -Lemma F25519_mul_OK : RepBinOpOK F25519RepConversions ModularArithmetic.mul F25519Rep_mul. - cbv iota beta delta [RepBinOpOK F25519RepConversions F25519Rep_mul toRep unRep F25519toRep F25519unRep]. - destruct x as [[[[[[[[[x9 x8] x7] x6] x5] x4] x3] x2] x1] x0]. - destruct y as [[[[[[[[[y9 y8] y7] y6] y5] y4] y3] y2] y1] y0]. - let E := constr:(GF25519Base25Point5_mul_reduce_formula x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 y0 y1 y2 y3 y4 y5 y6 y7 y8 y9) in - transitivity (ModularBaseSystem.decode (proj1_sig E)); [|solve[simpl;f_equal]]; - destruct E as [? r]; cbv [proj1_sig]. - cbv [rep ModularBaseSystem.rep PseudoMersenneBase modulus] in r; edestruct r; eauto. -Qed. - -Definition F25519Rep_add (f g:F25519Rep) : F25519Rep. - refine ( - let '(f9, f8, f7, f6, f5, f4, f3, f2, f1, f0) := f in - let '(g9, g8, g7, g6, g5, g4, g3, g2, g1, g0) := g in _). - let t' := (eval simpl in (proj1_sig (GF25519Base25Point5_add_formula f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 - g0 g1 g2 g3 g4 g5 g6 g7 g8 g9))) in - lazymatch t' with [?r0;?r1;?r2;?r3;?r4;?r5;?r6;?r7;?r8;?r9] => - exact (r9, r8, r7, r6, r5, r4, r3, r2, r1, r0) - end. -Defined. - -Definition F25519Rep_sub (f g:F25519Rep) : F25519Rep. - refine ( - let '(f9, f8, f7, f6, f5, f4, f3, f2, f1, f0) := f in - let '(g9, g8, g7, g6, g5, g4, g3, g2, g1, g0) := g in _). - let t' := (eval simpl in (proj1_sig (GF25519Base25Point5_sub_formula f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 - g0 g1 g2 g3 g4 g5 g6 g7 g8 g9))) in - lazymatch t' with [?r0;?r1;?r2;?r3;?r4;?r5;?r6;?r7;?r8;?r9] => - exact (r9, r8, r7, r6, r5, r4, r3, r2, r1, r0) - end. + eexists. + intros x Hf. + pose proof (freeze_opt_preserves_rep _ c_subst freezePreconditions25519 _ _ Hf) as Hfreeze_rep. + compute_formula. + exact Hfreeze_rep. Defined. -Lemma F25519_add_OK : RepBinOpOK F25519RepConversions ModularArithmetic.add F25519Rep_add. - cbv iota beta delta [RepBinOpOK F25519RepConversions F25519Rep_add toRep unRep F25519toRep F25519unRep]. - destruct x as [[[[[[[[[x9 x8] x7] x6] x5] x4] x3] x2] x1] x0]. - destruct y as [[[[[[[[[y9 y8] y7] y6] y5] y4] y3] y2] y1] y0]. - let E := constr:(GF25519Base25Point5_add_formula x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 y0 y1 y2 y3 y4 y5 y6 y7 y8 y9) in - transitivity (ModularBaseSystem.decode (proj1_sig E)); [|solve[simpl;f_equal]]; - destruct E as [? r]; cbv [proj1_sig]. - cbv [rep ModularBaseSystem.rep PseudoMersenneBase modulus] in r; edestruct r; eauto. -Qed. - -Lemma F25519_sub_OK : RepBinOpOK F25519RepConversions ModularArithmetic.sub F25519Rep_sub. - cbv iota beta delta [RepBinOpOK F25519RepConversions F25519Rep_sub toRep unRep F25519toRep F25519unRep]. - destruct x as [[[[[[[[[x9 x8] x7] x6] x5] x4] x3] x2] x1] x0]. - destruct y as [[[[[[[[[y9 y8] y7] y6] y5] y4] y3] y2] y1] y0]. - let E := constr:(GF25519Base25Point5_sub_formula x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 y0 y1 y2 y3 y4 y5 y6 y7 y8 y9) in - transitivity (ModularBaseSystem.decode (proj1_sig E)); [|solve[simpl;f_equal]]; - destruct E as [? r]; cbv [proj1_sig]. - cbv [rep ModularBaseSystem.rep PseudoMersenneBase modulus] in r; edestruct r; eauto. -Qed.
\ No newline at end of file +(* Uncomment the below to see pretty-printed freeze function *) +(* +Set Printing Depth 1000. +Local Transparent Let_In. +Infix "<<" := Z.shiftr (at level 50). +Infix "&" := Z.land (at level 50). +Eval cbv beta iota delta [proj1_sig GF25519Base25Point5_freeze_formula Let_In] in + fun f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 => proj1_sig ( + GF25519Base25Point5_freeze_formula f0 f1 f2 f3 f4 f5 f6 f7 f8 f9). +*)
\ No newline at end of file diff --git a/src/Tactics/Nsatz.v b/src/Tactics/Nsatz.v new file mode 100644 index 000000000..8fa8c4a86 --- /dev/null +++ b/src/Tactics/Nsatz.v @@ -0,0 +1,127 @@ +(*** Tactics for manipulating polynomial equations *) +Require Coq.nsatz.Nsatz. +Require Import List. + +Generalizable All Variables. +Lemma cring_sub_diag_iff {R zero eq sub} `{cring:Cring.Cring (R:=R) (ring0:=zero) (ring_eq:=eq) (sub:=sub)} + : forall x y, eq (sub x y) zero <-> eq x y. +Proof. + split;intros Hx. + { eapply Nsatz.psos_r1b. eapply Hx. } + { eapply Nsatz.psos_r1. eapply Hx. } +Qed. + +Ltac get_goal := lazymatch goal with |- ?g => g end. + +Ltac nsatz_equation_implications_to_list eq zero g := + lazymatch g with + | eq ?p zero => constr:(p::nil) + | eq ?p zero -> ?g => let l := nsatz_equation_implications_to_list eq zero g in constr:(p::l) + end. + +Ltac nsatz_reify_equations eq zero := + let g := get_goal in + let lb := nsatz_equation_implications_to_list eq zero g in + lazymatch (eval red in (Ncring_tac.list_reifyl (lterm:=lb))) with + (?variables, ?le) => + lazymatch (eval compute in (List.rev le)) with + | ?reified_goal::?reified_givens => constr:((variables, reified_givens, reified_goal)) + end + end. + +Ltac nsatz_get_free_variables reified_package := + lazymatch reified_package with (?fv, _, _) => fv end. + +Ltac nsatz_get_reified_givens reified_package := + lazymatch reified_package with (_, ?givens, _) => givens end. + +Ltac nsatz_get_reified_goal reified_package := + lazymatch reified_package with (_, _, ?goal) => goal end. + +Require Import Coq.setoid_ring.Ring_polynom. +(* Kludge for 8.4/8.5 compatibility *) +Module Import mynsatz_compute. + Import Nsatz. + Global Ltac mynsatz_compute x := nsatz_compute x. +End mynsatz_compute. +Ltac nsatz_compute x := mynsatz_compute x. + +Ltac nsatz_compute_to_goal sugar nparams reified_goal power reified_givens := + nsatz_compute (PEc sugar :: PEc nparams :: PEpow reified_goal power :: reified_givens). + +Ltac nsatz_compute_get_leading_coefficient := + lazymatch goal with + |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => a + end. + +Ltac nsatz_compute_get_certificate := + lazymatch goal with + |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => constr:((c,b)) + end. + +Ltac nsatz_rewrite_and_revert domain := + lazymatch type of domain with + | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring => + lazymatch goal with + | |- eq _ zero => idtac + | |- eq _ _ => rewrite <-(cring_sub_diag_iff (cring:=FCring)) + end; + repeat match goal with + | [H : eq _ zero |- _ ] => revert H + | [H : eq _ _ |- _ ] => rewrite <-(cring_sub_diag_iff (cring:=FCring)) in H; revert H + end + end. + +Ltac nsatz_nonzero := + try solve [apply Integral_domain.integral_domain_one_zero + |apply Integral_domain.integral_domain_minus_one_zero + |trivial]. + +Ltac nsatz_domain_sugar_power domain sugar power := + let nparams := constr:(BinInt.Zneg BinPos.xH) in (* some symbols can be "parameters", treated as coefficients *) + lazymatch type of domain with + | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring => + nsatz_rewrite_and_revert domain; + let reified_package := nsatz_reify_equations eq zero in + let fv := nsatz_get_free_variables reified_package in + let interp := constr:(@Nsatz.PEevalR _ _ _ _ _ _ _ _ Fops fv) in + let reified_givens := nsatz_get_reified_givens reified_package in + let reified_goal := nsatz_get_reified_goal reified_package in + nsatz_compute_to_goal sugar nparams reified_goal power reified_givens; + let a := nsatz_compute_get_leading_coefficient in + let crt := nsatz_compute_get_certificate in + intros _ (* discard [nsatz_compute] output *); intros; + apply (fun Haa refl cond => @Integral_domain.Rintegral_domain_pow _ _ _ _ _ _ _ _ _ _ _ domain (interp a) _ (BinNat.N.to_nat power) Haa (@Nsatz.check_correct _ _ _ _ _ _ _ _ _ _ FCring fv reified_givens (PEmul a (PEpow reified_goal power)) crt refl cond)); + [ nsatz_nonzero; cbv iota beta delta [Nsatz.PEevalR PEeval InitialRing.gen_phiZ InitialRing.gen_phiPOS] + | solve [vm_compute; exact (eq_refl true)] (* exact_no_check (eq_refl true) *) + | solve [repeat (split; [assumption|]); exact I] ] + end. + +Ltac nsatz_guess_domain := + match goal with + | |- ?eq _ _ => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq)) + | |- not (?eq _ _) => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq)) + | [H: ?eq _ _ |- _ ] => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq)) + | [H: not (?eq _ _) |- _] => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq)) + end. + +Ltac nsatz_sugar_power sugar power := + let domain := nsatz_guess_domain in + nsatz_domain_sugar_power domain sugar power. + +Tactic Notation "nsatz" constr(n) := + let nn := (eval compute in (BinNat.N.of_nat n)) in + nsatz_sugar_power BinInt.Z0 nn. + +Tactic Notation "nsatz" := nsatz 1%nat || nsatz 2%nat || nsatz 3%nat || nsatz 4%nat || nsatz 5%nat. + +Ltac nsatz_contradict := + unfold not; + intros; + let domain := nsatz_guess_domain in + lazymatch type of domain with + | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring => + assert (eq one zero) as Hbad; + [nsatz; nsatz_nonzero + |destruct (Integral_domain.integral_domain_one_zero (Integral_domain:=domain) Hbad)] + end. diff --git a/src/Testbit.v b/src/Testbit.v index 264069587..2bfcc3df6 100644 --- a/src/Testbit.v +++ b/src/Testbit.v @@ -3,6 +3,7 @@ Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil. Require Import Crypto.BaseSystem Crypto.BaseSystemProofs. Require Import Coq.ZArith.ZArith Coq.ZArith.Zdiv. Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith. +Import Nat. Local Open Scope Z. @@ -209,4 +210,4 @@ Lemma testbit_spec : forall n us base limb_width, (0 < limb_width)%nat -> Proof. intros. erewrite unfold_bits_testbit, unfold_bits_decode; eauto; omega. -Qed.
\ No newline at end of file +Qed. diff --git a/src/Util/CaseUtil.v b/src/Util/CaseUtil.v index cf3ebf29c..2d1ab6c58 100644 --- a/src/Util/CaseUtil.v +++ b/src/Util/CaseUtil.v @@ -1,12 +1,12 @@ -Require Import Coq.Arith.Arith. +Require Import Coq.Arith.Arith Coq.Arith.Max. Ltac case_max := match goal with [ |- context[max ?x ?y] ] => destruct (le_dec x y); match goal with - | [ H : (?x <= ?y)%nat |- context[max ?x ?y] ] => rewrite Max.max_r by + | [ H : (?x <= ?y)%nat |- context[max ?x ?y] ] => rewrite max_r by (exact H) - | [ H : ~ (?x <= ?y)%nat |- context[max ?x ?y] ] => rewrite Max.max_l by + | [ H : ~ (?x <= ?y)%nat |- context[max ?x ?y] ] => rewrite max_l by (exact (le_Sn_le _ _ (not_le _ _ H))) end end. diff --git a/src/Util/IterAssocOp.v b/src/Util/IterAssocOp.v index 6116312e1..82d22046d 100644 --- a/src/Util/IterAssocOp.v +++ b/src/Util/IterAssocOp.v @@ -1,5 +1,7 @@ Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Classes.Equivalence. Require Import Coq.NArith.NArith Coq.PArith.BinPosDef. +Require Import Coq.Numbers.Natural.Peano.NPeano. + Local Open Scope equiv_scope. Generalizable All Variables. @@ -147,7 +149,7 @@ Section IterAssocOp. destruct (funexp (test_and_op n a) (x, acc) y) as [i acc']. simpl in IHy. unfold test_and_op. - destruct i; rewrite NPeano.Nat.sub_succ_r; subst; rewrite <- IHy; simpl; reflexivity. + destruct i; rewrite Nat.sub_succ_r; subst; rewrite <- IHy; simpl; reflexivity. Qed. Lemma iter_op_termination : forall sc a bound, diff --git a/src/Util/ListUtil.v b/src/Util/ListUtil.v index 36d8a3ad3..0426c0834 100644 --- a/src/Util/ListUtil.v +++ b/src/Util/ListUtil.v @@ -18,7 +18,7 @@ Proof. intros. induction n; boring. Qed. -Ltac nth_tac' := +Ltac nth_tac' := intros; simpl in *; unfold error,value in *; repeat progress (match goal with | [ |- context[nth_error nil ?n] ] => rewrite nth_error_nil_error | [ H: ?x = Some _ |- context[match ?x with Some _ => ?a | None => ?a end ] ] => destruct x @@ -79,10 +79,10 @@ Proof. reflexivity. nth_tac'. pose proof (nth_error_error_length A n l H0). - omega. + omega. Qed. -Ltac nth_tac := +Ltac nth_tac := repeat progress (try nth_tac'; try (match goal with | [ H: nth_error (map _ _) _ = Some _ |- _ ] => destruct (nth_error_map _ _ _ _ _ _ H); clear H | [ H: nth_error (seq _ _) _ = Some _ |- _ ] => rewrite nth_error_seq in H @@ -191,7 +191,7 @@ Proof. Qed. Lemma set_nth_equiv_splice_nth: forall {T} n x (xs:list T), - set_nth n x xs = + set_nth n x xs = if lt_dec n (length xs) then splice_nth n x xs else xs. @@ -210,7 +210,7 @@ Lemma combine_set_nth : forall {A B} n (x:A) xs (ys:list B), end. Proof. (* TODO(andreser): this proof can totally be automated, but requires writing ltac that vets multiple hypotheses at once *) - induction n, xs, ys; nth_tac; try rewrite IHn; nth_tac; + induction n, xs, ys; nth_tac; try rewrite IHn; nth_tac; try (f_equal; specialize (IHn x xs ys ); rewrite H in IHn; rewrite <- IHn); try (specialize (nth_error_value_length _ _ _ _ H); omega). assert (Some b0=Some b1) as HA by (rewrite <-H, <-H0; auto). @@ -258,13 +258,13 @@ Proof. destruct (lt_dec n (length xs)); auto. Qed. -Lemma combine_truncate_r : forall {A} (xs ys : list A), +Lemma combine_truncate_r : forall {A B} (xs : list A) (ys : list B), combine xs ys = combine xs (firstn (length xs) ys). Proof. induction xs; destruct ys; boring. Qed. -Lemma combine_truncate_l : forall {A} (xs ys : list A), +Lemma combine_truncate_l : forall {A B} (xs : list A) (ys : list B), combine xs ys = combine (firstn (length ys) xs) ys. Proof. induction xs; destruct ys; boring. @@ -330,7 +330,7 @@ Proof. intros. rewrite firstn_app_inleft; auto using firstn_all; omega. Qed. - + Lemma skipn_app_sharp : forall {A} n (l l': list A), length l = n -> skipn n (l ++ l') = l'. @@ -422,7 +422,7 @@ Proof. right; repeat eexists; auto. } Qed. - + Lemma nil_length0 : forall {T}, length (@nil T) = 0%nat. Proof. auto. @@ -512,7 +512,7 @@ Ltac nth_error_inbounds := match goal with | [ |- context[match nth_error ?xs ?i with Some _ => _ | None => _ end ] ] => case_eq (nth_error xs i); - match goal with + match goal with | [ |- forall _, nth_error xs i = Some _ -> _ ] => let x := fresh "x" in let H := fresh "H" in @@ -582,3 +582,46 @@ Lemma In_firstn : forall {T} n l (x : T), In x (firstn n l) -> In x l. Proof. induction n; destruct l; boring. Qed. + +Lemma firstn_firstn : forall {A} m n (l : list A), (n <= m)%nat -> + firstn n (firstn m l) = firstn n l. +Proof. + induction m; destruct n; intros; try omega; auto. + destruct l; auto. + simpl. + f_equal. + apply IHm; omega. +Qed. + +Lemma firstn_succ : forall {A} (d : A) n l, (n < length l)%nat -> + firstn (S n) l = (firstn n l) ++ nth_default d l n :: nil. +Proof. + induction n; destruct l; rewrite ?(@nil_length0 A); intros; try omega. + + rewrite nth_default_cons; auto. + + simpl. + rewrite nth_default_cons_S. + rewrite <-IHn by (rewrite cons_length in *; omega). + reflexivity. +Qed. + +Lemma firstn_all_strong : forall {A} (xs : list A) n, (length xs <= n)%nat -> + firstn n xs = xs. +Proof. + induction xs; intros; try apply firstn_nil. + destruct n; + match goal with H : (length (_ :: _) <= _)%nat |- _ => + simpl in H; try omega end. + simpl. + f_equal. + apply IHxs. + omega. +Qed. + +Lemma set_nth_nth_default : forall {A} (d:A) n x l i, (0 <= i < length l)%nat -> + nth_default d (set_nth n x l) i = + if (eq_nat_dec i n) then x else nth_default d l i. +Proof. + induction n; (destruct l; [intros; simpl in *; omega | ]); simpl; + destruct i; break_if; try omega; intros; try apply nth_default_cons; + rewrite !nth_default_cons_S, ?IHn; try break_if; omega || reflexivity. +Qed.
\ No newline at end of file diff --git a/src/Util/NatUtil.v b/src/Util/NatUtil.v index 1f69b04d2..bc2c8425b 100644 --- a/src/Util/NatUtil.v +++ b/src/Util/NatUtil.v @@ -1,4 +1,5 @@ Require Import Coq.Numbers.Natural.Peano.NPeano Coq.omega.Omega. +Import Nat. Local Open Scope nat_scope. @@ -57,7 +58,18 @@ Proof. } Qed. +Lemma lt_min_l : forall x a b, (x < min a b)%nat -> (x < a)%nat. +Proof. + intros ? ? ? lt_min. + apply Nat.min_glb_lt_iff in lt_min. + destruct lt_min; assumption. +Qed. +(* useful for hints *) +Lemma eq_le_incl_rev : forall a b, a = b -> b <= a. +Proof. + intros; omega. +Qed. Lemma beq_nat_eq_nat_dec {R} (x y : nat) (a b : R) : (if EqNat.beq_nat x y then a else b) = (if eq_nat_dec x y then a else b). @@ -66,4 +78,3 @@ Proof. [ rewrite (proj2 (@beq_nat_true_iff _ _) H); reflexivity | rewrite (proj2 (@beq_nat_false_iff _ _) H); reflexivity ]. Qed. - diff --git a/src/Util/Tuple.v b/src/Util/Tuple.v new file mode 100644 index 000000000..6802a86c3 --- /dev/null +++ b/src/Util/Tuple.v @@ -0,0 +1,81 @@ +Require Import Coq.Classes.Morphisms. +Require Import Relation_Definitions. + +Fixpoint tuple' T n : Type := + match n with + | O => T + | S n' => (tuple' T n' * T)%type + end. + +Definition tuple T n : Type := + match n with + | O => unit + | S n' => tuple' T n' + end. + +Fixpoint to_list' {T} (n:nat) {struct n} : tuple' T n -> list T := + match n with + | 0 => fun x => (x::nil)%list + | S n' => fun xs : tuple' T (S n') => let (xs', x) := xs in (x :: to_list' n' xs')%list + end. + +Definition to_list {T} (n:nat) : tuple T n -> list T := + match n with + | 0 => fun _ => nil + | S n' => fun xs : tuple T (S n') => to_list' n' xs + end. + +Fixpoint from_list' {T} (x:T) (xs:list T) : tuple' T (length xs) := + match xs with + | nil => x + | (y :: xs')%list => (from_list' y xs', x) + end. + +Definition from_list {T} (xs:list T) : tuple T (length xs) := + match xs as l return (tuple T (length l)) with + | nil => tt + | (t :: xs')%list => from_list' t xs' + end. + +Lemma to_list_from_list : forall {T} (xs:list T), to_list (length xs) (from_list xs) = xs. +Proof. + destruct xs; auto; simpl. + generalize dependent t. + induction xs; auto; simpl; intros; f_equal; auto. +Qed. + +Lemma length_to_list : forall {T} {n} (xs:tuple T n), length (to_list n xs) = n. +Proof. + destruct n; auto; intros; simpl in *. + induction n; auto; intros; simpl in *. + destruct xs; simpl in *; eauto. +Qed. + +Fixpoint fieldwise' {A B} (n:nat) (R:A->B->Prop) (a:tuple' A n) (b:tuple' B n) {struct n} : Prop. + destruct n; simpl @tuple' in *. + { exact (R a b). } + { exact (R (snd a) (snd b) /\ fieldwise' _ _ n R (fst a) (fst b)). } +Defined. + +Definition fieldwise {A B} (n:nat) (R:A->B->Prop) (a:tuple A n) (b:tuple B n) : Prop. + destruct n; simpl @tuple in *. + { exact True. } + { exact (fieldwise' _ R a b). } +Defined. + +Global Instance Equivalence_fieldwise' {A} {R:relation A} {R_equiv:Equivalence R} {n:nat}: + Equivalence (fieldwise' n R). +Proof. + induction n as [|? IHn]; [solve [auto]|]. + (* could use [dintuition] in 8.5 only, and remove the [destruct] *) + destruct IHn, R_equiv; simpl; constructor; repeat intro; intuition eauto. +Qed. + +Global Instance Equivalence_fieldwise {A} {R:relation A} {R_equiv:Equivalence R} {n:nat}: + Equivalence (fieldwise n R). +Proof. + destruct n; (repeat constructor || apply Equivalence_fieldwise'). +Qed. + +Arguments fieldwise' {A B n} _ _ _. +Arguments fieldwise {A B n} _ _ _. diff --git a/src/Util/ZUtil.v b/src/Util/ZUtil.v index 1b7cfafdc..a5716fca4 100644 --- a/src/Util/ZUtil.v +++ b/src/Util/ZUtil.v @@ -2,6 +2,7 @@ Require Import Coq.ZArith.Zpower Coq.ZArith.Znumtheory Coq.ZArith.ZArith Coq.ZAr Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith. Require Import Crypto.Util.NatUtil. Require Import Coq.Lists.List. +Import Nat. Local Open Scope Z. Lemma gt_lt_symmetry: forall n m, n > m <-> m < n. @@ -208,7 +209,7 @@ Proof. rewrite (le_plus_minus n m) at 1 by assumption. rewrite Nat2Z.inj_add. rewrite Z.pow_add_r by apply Nat2Z.is_nonneg. - rewrite <- Z.div_div by first + rewrite <- Z.div_div by first [ pose proof (Z.pow_pos_nonneg 2 (Z.of_nat n)); omega | apply Z.pow_pos_nonneg; omega ]. rewrite Z.div_add by (pose proof (Z.pow_pos_nonneg 2 (Z.of_nat n)); omega). @@ -332,7 +333,7 @@ Qed. replace (2 ^ (Z.pos p)) with (2 ^ (Z.pos p - 1)* 2). rewrite Z.div_add_l by omega. reflexivity. - replace 2 with (2 ^ 1) at 2 by auto. + change 2 with (2 ^ 1) at 2. rewrite <-Z.pow_add_r by (pose proof (Pos2Z.is_pos p); omega). f_equal. omega. Qed. @@ -345,7 +346,7 @@ Qed. + unfold Z.ones. rewrite Z.shiftr_0_r, Z.shiftl_1_l, Z.sub_0_r. omega. - + intros. + + intros. destruct (Z_lt_le_dec x n); try omega. intuition. left. @@ -360,7 +361,7 @@ Qed. Z.shiftr a i <= Z.ones (n - i) . Proof. intros a n i G G0 G1. - destruct (Z_le_lt_eq_dec i n G1). + destruct (Z_le_lt_eq_dec i n G1). + destruct (Z_shiftr_ones' a n G i G0); omega. + subst; rewrite Z.sub_diag. destruct (Z_eq_dec a 0). @@ -385,34 +386,91 @@ Qed. omega. Qed. -(* prove that known nonnegative numbers are nonnegative *) +(* prove that combinations of known positive/nonnegative numbers are positive/nonnegative *) Ltac zero_bounds' := repeat match goal with | [ |- 0 <= _ + _] => apply Z.add_nonneg_nonneg - | [ |- 0 <= _ - _] => apply Zle_minus_le_0 + | [ |- 0 <= _ - _] => apply Z.le_0_sub | [ |- 0 <= _ * _] => apply Z.mul_nonneg_nonneg | [ |- 0 <= _ / _] => apply Z.div_pos - | [ |- 0 < _ + _] => apply Z.add_pos_nonneg - (* TODO : this apply is not good: it can make a true goal false. Actually, - * we would want this tactic to explore two branches: - * - apply Z.add_pos_nonneg and continue - * - apply Z.add_nonneg_pos and continue - * Keep whichever one solves all subgoals. If neither does, don't apply. *) - - | [ |- 0 < _ - _] => apply Zlt_minus_lt_0 + | [ |- 0 <= _ ^ _ ] => apply Z.pow_nonneg + | [ |- 0 <= Z.shiftr _ _] => apply Z.shiftr_nonneg + | [ |- 0 < _ + _] => try solve [apply Z.add_pos_nonneg; zero_bounds']; + try solve [apply Z.add_nonneg_pos; zero_bounds'] + | [ |- 0 < _ - _] => apply Z.lt_0_sub | [ |- 0 < _ * _] => apply Z.lt_0_mul; left; split | [ |- 0 < _ / _] => apply Z.div_str_pos + | [ |- 0 < _ ^ _ ] => apply Z.pow_pos_nonneg end; try omega; try prime_bound; auto. Ltac zero_bounds := try omega; try prime_bound; zero_bounds'. - Lemma Z_ones_nonneg : forall i, (0 <= i) -> 0 <= Z.ones i. - Proof. - apply natlike_ind. - + unfold Z.ones. simpl; omega. - + intros. - rewrite Z_ones_succ by assumption. - zero_bounds. - apply Z.pow_nonneg; omega. - Qed. +Lemma Z_ones_nonneg : forall i, (0 <= i) -> 0 <= Z.ones i. +Proof. + apply natlike_ind. + + unfold Z.ones. simpl; omega. + + intros. + rewrite Z_ones_succ by assumption. + zero_bounds. +Qed. + +Lemma Z_ones_pos_pos : forall i, (0 < i) -> 0 < Z.ones i. +Proof. + intros. + unfold Z.ones. + rewrite Z.shiftl_1_l. + apply Z.lt_succ_lt_pred. + apply Z.pow_gt_1; omega. +Qed. + +Lemma N_le_1_l : forall p, (1 <= N.pos p)%N. +Proof. + destruct p; cbv; congruence. +Qed. +Lemma Pos_land_upper_bound_l : forall a b, (Pos.land a b <= N.pos a)%N. +Proof. + induction a; destruct b; intros; try solve [cbv; congruence]; + simpl; specialize (IHa b); case_eq (Pos.land a b); intro; simpl; + try (apply N_le_1_l || apply N.le_0_l); intro land_eq; + rewrite land_eq in *; unfold N.le, N.compare in *; + rewrite ?Pos.compare_xI_xI, ?Pos.compare_xO_xI, ?Pos.compare_xO_xO; + try assumption. + destruct (p ?=a)%positive; cbv; congruence. +Qed. + +Lemma Z_land_upper_bound_l : forall a b, (0 <= a) -> (0 <= b) -> + Z.land a b <= a. +Proof. + intros. + destruct a, b; try solve [exfalso; auto]; try solve [cbv; congruence]. + cbv [Z.land]. + rewrite <-N2Z.inj_pos, <-N2Z.inj_le. + auto using Pos_land_upper_bound_l. +Qed. + +Lemma Z_land_upper_bound_r : forall a b, (0 <= a) -> (0 <= b) -> + Z.land a b <= b. +Proof. + intros. + rewrite Z.land_comm. + auto using Z_land_upper_bound_l. +Qed. + +Lemma Z_le_fold_right_max : forall low l x, (forall y, In y l -> low <= y) -> + In x l -> x <= fold_right Z.max low l. +Proof. + induction l; intros ? lower_bound In_list; [cbv [In] in *; intuition | ]. + simpl. + destruct (in_inv In_list); subst. + + apply Z.le_max_l. + + etransitivity. + - apply IHl; auto; intuition. + - apply Z.le_max_r. +Qed. + +Lemma Z_le_fold_right_max_initial : forall low l, low <= fold_right Z.max low l. +Proof. + induction l; intros; try reflexivity. + etransitivity; [ apply IHl | apply Z.le_max_r ]. +Qed. |