diff options
| author |  jadep <jade.philipoom@gmail.com> | 2016-06-24 23:12:15 -0400 |
|---|---|---|
| committer | jadep <jade.philipoom@gmail.com> | 2016-06-24 23:12:20 -0400 |
| commit | 377c567946c7d12eabafc0cf4b91ed0bf1d1d997 (patch) | |
| tree | 262fe92afa2eebf2b3f384c38498cb8795cf8fc5 | |
| parent | 9fed6f528e57fb25972bd991dae726a9b5f8b106 (diff) | |
| parent | 61bdcf3de1f506907d62a2a7c32594c1a666d474 (diff) | |
merging point encoding port
117 files changed, 6303 insertions, 2719 deletions
diff --git a/.gitignore b/.gitignore index 8726df21c..9028c237e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ bedrock fiat *~ +*# *.vo *.d *.glob diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 000000000..eb73fc298 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "etc/coq-scripts"] + path = etc/coq-scripts + url = https://github.com/JasonGross/coq-scripts.git @@ -9,6 +9,7 @@ Jade Philipoom <jadep@mit.edu> Jade Philipoom <jadep 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> diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..1092e385a --- /dev/null +++ b/.travis.yml @@ -0,0 +1,16 @@ +language: generic + +sudo: required +dist: trusty + +env: + matrix: + - COQ_VERSION="8.4" COQPRIME="coqprime-8.4" + - COQ_VERSION="8.5" COQPRIME="coqprime" + +before_install: + - if [ "$COQ_VERSION" == "8.5" ]; then sudo add-apt-repository ppa:jgross-h/coq-backports -y; fi + - sudo apt-get update -q + - sudo apt-get install coq -y + +script: make COQPATH="$(pwd)/$COQPRIME" TIMED=1 -j2 diff --git a/Bedrock/Word.v b/Bedrock/Word.v index a33d108fb..8ae651826 100644 --- a/Bedrock/Word.v +++ b/Bedrock/Word.v @@ -849,21 +849,21 @@ Implicit Arguments weqb_sound []. Ltac isWcst w := match eval hnf in w with - | WO => constr:true + | WO => constr:(true) | WS ?b ?w' => match eval hnf in b with | true => isWcst w' | false => isWcst w' - | _ => constr:false + | _ => constr:(false) end - | _ => constr:false + | _ => constr:(false) end. Ltac wcst w := let b := isWcst w in match b with | true => w - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. (* Here's how you can add a ring for a specific bit-width. @@ -17,7 +17,6 @@ SILENCE_COQDEP = $(SILENCE_COQDEP_$(VERBOSE)) SORT_COQPROJECT = sed 's,[^/]*/,~&,g' | env LC_COLLATE=C sort | sed 's,~,,g' update-_CoqProject:: - $(VECHO) "GIT LS-FILES *.V > _COQPROJECT" $(Q)(echo '-R $(SRC_DIR) $(MOD_NAME)'; echo '-R Bedrock Bedrock'; (git ls-files 'src/*.v' 'Bedrock/*.v' | $(SORT_COQPROJECT))) > _CoqProject coq: coqprime Makefile.coq @@ -26,20 +25,19 @@ coq: coqprime Makefile.coq COQ_VERSION_PREFIX = The Coq Proof Assistant, version COQ_VERSION := $(firstword $(subst $(COQ_VERSION_PREFIX),,$(shell $(COQBIN)coqc --version 2>/dev/null))) -ifneq ($(filter 8.5%,$(COQ_VERSION)),) # 8.5 -coqprime: coqprime-8.5 -else +ifneq ($(filter 8.4%,$(COQ_VERSION)),) # 8.4 coqprime: coqprime-8.4 +else +coqprime: coqprime-8.5 endif coqprime-8.4: - $(MAKE) -C coqprime + $(MAKE) -C coqprime-8.4 coqprime-8.5: - $(MAKE) -C coqprime-8.5 + $(MAKE) -C coqprime Makefile.coq: Makefile _CoqProject - $(VECHO) "COQ_MAKEFILE" $(Q)$(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq clean: Makefile.coq @@ -1,13 +1,17 @@ +[](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 gibhub.com repo is only intermittently synced with -github.mit.edu. If you're in CSAIL, you should pull from the -github.mit.edu repo. +NOTE: The github.com repo is only intermittently synced with +github.mit.edu. -To build: +To build (Coq 8.5): export COQPATH="$(pwd)/coqprime${COQPATH:+:}$COQPATH" make + +To build with Coq 8.4 + + export COQPATH="$(pwd)/coqprime-8.4${COQPATH:+:}$COQPATH" + make diff --git a/_CoqProject b/_CoqProject index 4b36c103b..afad38124 100644 --- a/_CoqProject +++ b/_CoqProject @@ -2,23 +2,36 @@ -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/Assembly/AlmostConversion.v +src/Assembly/AlmostQhasm.v +src/Assembly/Conversion.v +src/Assembly/Language.v +src/Assembly/Pipeline.v +src/Assembly/Pseudize.v +src/Assembly/Pseudo.v +src/Assembly/PseudoConversion.v +src/Assembly/Qhasm.v +src/Assembly/QhasmCommon.v +src/Assembly/QhasmEvalCommon.v +src/Assembly/QhasmUtil.v +src/Assembly/State.v +src/Assembly/StringConversion.v +src/Assembly/Vectorize.v +src/Assembly/Wordize.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 @@ -30,21 +43,24 @@ 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/Decidable.v src/Util/IterAssocOp.v src/Util/ListUtil.v src/Util/NatUtil.v +src/Util/Notations.v src/Util/NumTheoryUtil.v +src/Util/Sum.v src/Util/Tactics.v +src/Util/Tuple.v +src/Util/Unit.v src/Util/WordUtil.v src/Util/ZUtil.v diff --git a/coqprime-8.5/Coqprime/Cyclic.v b/coqprime-8.4/Coqprime/Cyclic.v index c25f683ca..e2daa4d67 100644 --- a/coqprime-8.5/Coqprime/Cyclic.v +++ b/coqprime-8.4/Coqprime/Cyclic.v @@ -11,13 +11,13 @@ 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. +Require Import Coqprime.ZCAux. +Require Import Coq.Lists.List. +Require Import Coqprime.Root. +Require Import Coqprime.UList. +Require Import Coqprime.IGroup. +Require Import Coqprime.EGroup. +Require Import Coqprime.FGroup. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/EGroup.v b/coqprime-8.4/Coqprime/EGroup.v index 933176abd..553cb746c 100644 --- a/coqprime-8.5/Coqprime/EGroup.v +++ b/coqprime-8.4/Coqprime/EGroup.v @@ -11,15 +11,15 @@ 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. +Require Import Coq.ZArith.ZArith. +Require Import Coqprime.Tactic. +Require Import Coq.Lists.List. +Require Import Coqprime.ZCAux. +Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. +Require Import Coq.Arith.Wf_nat. +Require Import Coqprime.UList. +Require Import Coqprime.FGroup. +Require Import Coqprime.Lagrange. Open Scope Z_scope. @@ -43,7 +43,7 @@ Hypothesis a_in_G: In a G.(s). **************************************) Set Implicit Arguments. -Definition gpow n := match n with Zpos p => iter_pos _ (op a) G.(e) p | _ => G.(e) end. +Definition gpow n := match n with Zpos p => iter_pos p _ (op a) G.(e) | _ => G.(e) end. Unset Implicit Arguments. Theorem gpow_0: gpow 0 = G.(e). @@ -63,17 +63,17 @@ 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. +Theorem gpow_op: forall b p, In b G.(s) -> iter_pos p _ (op a) b = op (iter_pos p _ (op a) G.(e)) 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. +rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos p A x y)); 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. +rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos p A x y)); auto. repeat rewrite G.(assoc); auto. intros b H; rewrite e_is_zero_r; auto. Qed. @@ -87,7 +87,7 @@ 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. +rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos p2 A x y)); auto. exact (gpow_in (Zpos p2)). Qed. @@ -445,7 +445,7 @@ 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)). +assert(H1: In (iter_pos p1 A (op a) (e G)) (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. @@ -486,12 +486,12 @@ 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)). +assert(H1: In (iter_pos p3 A (op a) (e G)) (s G)). refine (gpow_in _ _ _ _ _ (Zpos p3)); auto. -assert(H2: In (iter_pos A (op b) (e G) p3) (s G)). +assert(H2: In (iter_pos p3 A (op b) (e G)) (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 (fun x y => comm (iter_pos p3 A x y) b); auto. rewrite (G.(assoc) a); try apply comm; auto. Qed. diff --git a/coqprime-8.5/Coqprime/Euler.v b/coqprime-8.4/Coqprime/Euler.v index 06d92ce57..e571d8e3c 100644 --- a/coqprime-8.5/Coqprime/Euler.v +++ b/coqprime-8.4/Coqprime/Euler.v @@ -11,10 +11,10 @@ Definition of the Euler Totient function *************************************************************************) -Require Import ZArith. -Require Export Znumtheory. -Require Import Tactic. -Require Export ZSum. +Require Import Coq.ZArith.ZArith. +Require Export Coq.ZArith.Znumtheory. +Require Import Coqprime.Tactic. +Require Export Coqprime.ZSum. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/FGroup.v b/coqprime-8.4/Coqprime/FGroup.v index a55710e7c..0bcc9ebf1 100644 --- a/coqprime-8.5/Coqprime/FGroup.v +++ b/coqprime-8.4/Coqprime/FGroup.v @@ -13,10 +13,10 @@ Definition: FGroup **********************************************************************) -Require Import List. -Require Import UList. -Require Import Tactic. -Require Import ZArith. +Require Import Coq.Lists.List. +Require Import Coqprime.UList. +Require Import Coqprime.Tactic. +Require Import Coq.ZArith.ZArith. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/IGroup.v b/coqprime-8.4/Coqprime/IGroup.v index 11a73d414..04219be5a 100644 --- a/coqprime-8.5/Coqprime/IGroup.v +++ b/coqprime-8.4/Coqprime/IGroup.v @@ -13,12 +13,12 @@ Definition: ZpGroup **********************************************************************) -Require Import ZArith. -Require Import Tactic. -Require Import Wf_nat. -Require Import UList. -Require Import ListAux. -Require Import FGroup. +Require Import Coq.ZArith.ZArith. +Require Import Coqprime.Tactic. +Require Import Coq.Arith.Wf_nat. +Require Import Coqprime.UList. +Require Import Coqprime.ListAux. +Require Import Coqprime.FGroup. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/Iterator.v b/coqprime-8.4/Coqprime/Iterator.v index 96d3e5655..e84687cd4 100644 --- a/coqprime-8.5/Coqprime/Iterator.v +++ b/coqprime-8.4/Coqprime/Iterator.v @@ -6,9 +6,9 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export List. -Require Export Permutation. -Require Import Arith. +Require Export Coq.Lists.List. +Require Export Coqprime.Permutation. +Require Import Coq.Arith.Arith. Section Iterator. Variables A B : Set. diff --git a/coqprime-8.5/Coqprime/Lagrange.v b/coqprime-8.4/Coqprime/Lagrange.v index b35460bad..b890c5621 100644 --- a/coqprime-8.5/Coqprime/Lagrange.v +++ b/coqprime-8.4/Coqprime/Lagrange.v @@ -14,12 +14,12 @@ Definition: lagrange **********************************************************************) -Require Import List. -Require Import UList. -Require Import ListAux. -Require Import ZArith Znumtheory. -Require Import NatAux. -Require Import FGroup. +Require Import Coq.Lists.List. +Require Import Coqprime.UList. +Require Import Coqprime.ListAux. +Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. +Require Import Coqprime.NatAux. +Require Import Coqprime.FGroup. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/ListAux.v b/coqprime-8.4/Coqprime/ListAux.v index c3c9602bd..4ed154685 100644 --- a/coqprime-8.5/Coqprime/ListAux.v +++ b/coqprime-8.4/Coqprime/ListAux.v @@ -11,11 +11,11 @@ Auxillary functions & Theorems **********************************************************************) -Require Export List. -Require Export Arith. -Require Export Tactic. -Require Import Inverse_Image. -Require Import Wf_nat. +Require Export Coq.Lists.List. +Require Export Coq.Arith.Arith. +Require Export Coqprime.Tactic. +Require Import Coq.Wellfounded.Inverse_Image. +Require Import Coq.Arith.Wf_nat. (************************************** Some properties on list operators: app, map,... diff --git a/coqprime-8.5/Coqprime/LucasLehmer.v b/coqprime-8.4/Coqprime/LucasLehmer.v index a0e3b8e46..c459195a8 100644 --- a/coqprime-8.5/Coqprime/LucasLehmer.v +++ b/coqprime-8.4/Coqprime/LucasLehmer.v @@ -13,17 +13,17 @@ 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. +Require Import Coq.ZArith.ZArith. +Require Import Coqprime.ZCAux. +Require Import Coqprime.Tactic. +Require Import Coq.Arith.Wf_nat. +Require Import Coqprime.NatAux. +Require Import Coqprime.UList. +Require Import Coqprime.ListAux. +Require Import Coqprime.FGroup. +Require Import Coqprime.EGroup. +Require Import Coqprime.PGroup. +Require Import Coqprime.IGroup. Open Scope Z_scope. @@ -47,7 +47,7 @@ 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. +Definition ppow p n := match n with Zpos q => iter_pos q _ (pmult p) (1, 0) | _ => (1, 0) end. (************************************** Some properties of ppow @@ -63,14 +63,14 @@ 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. +Theorem ppow_op: forall a b p, iter_pos p _ (pmult a) b = pmult (iter_pos p _ (pmult a) (1, 0)) 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. +try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos p _ x y)); 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. +rewrite (Rec b); try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos p _ x y)); auto. repeat rewrite pmult_assoc; auto. intros b; rewrite pmult_1_r; auto. Qed. @@ -114,7 +114,7 @@ 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 (fun x y => pmult_comm (iter_pos p3 _ x y) p); auto. rewrite (pmult_assoc m); try apply pmult_comm; auto. Qed. @@ -490,13 +490,13 @@ End Lucas. 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 + Zpos p1 => iter_pos p1 _ (fun x => Zmodd (Zsquare x - 2) n) (Zmodd 4 n) | _ => (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. + iter_pos p _ (fun x => Zmodd (Zsquare x - 2) z1) z2 = 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. diff --git a/coqprime/Coqprime/Makefile.bak b/coqprime-8.4/Coqprime/Makefile.bak index fe49dbf29..fe49dbf29 100644 --- a/coqprime/Coqprime/Makefile.bak +++ b/coqprime-8.4/Coqprime/Makefile.bak diff --git a/coqprime-8.5/Coqprime/NatAux.v b/coqprime-8.4/Coqprime/NatAux.v index eab09150c..6df511eed 100644 --- a/coqprime-8.5/Coqprime/NatAux.v +++ b/coqprime-8.4/Coqprime/NatAux.v @@ -11,7 +11,7 @@ Auxillary functions & Theorems **********************************************************************) -Require Export Arith. +Require Export Coq.Arith.Arith. (************************************** Some properties of minus diff --git a/coqprime/Coqprime/Note.pdf b/coqprime-8.4/Coqprime/Note.pdf Binary files differindex 239a38772..239a38772 100644 --- a/coqprime/Coqprime/Note.pdf +++ b/coqprime-8.4/Coqprime/Note.pdf diff --git a/coqprime-8.5/Coqprime/PGroup.v b/coqprime-8.4/Coqprime/PGroup.v index e9c1b2f47..19eff5850 100644 --- a/coqprime-8.5/Coqprime/PGroup.v +++ b/coqprime-8.4/Coqprime/PGroup.v @@ -14,15 +14,15 @@ 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. +Require Import Coq.ZArith.ZArith. +Require Import Coq.ZArith.Znumtheory. +Require Import Coqprime.Tactic. +Require Import Coq.Arith.Wf_nat. +Require Import Coqprime.ListAux. +Require Import Coqprime.UList. +Require Import Coqprime.FGroup. +Require Import Coqprime.EGroup. +Require Import Coqprime.IGroup. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/Permutation.v b/coqprime-8.4/Coqprime/Permutation.v index a06693f89..7cb6f629d 100644 --- a/coqprime-8.5/Coqprime/Permutation.v +++ b/coqprime-8.4/Coqprime/Permutation.v @@ -11,8 +11,8 @@ Defintion and properties of permutations **********************************************************************) -Require Export List. -Require Export ListAux. +Require Export Coq.Lists.List. +Require Export Coqprime.ListAux. Section permutation. Variable A : Set. diff --git a/coqprime-8.5/Coqprime/Pmod.v b/coqprime-8.4/Coqprime/Pmod.v index f64af48e3..45961896e 100644 --- a/coqprime-8.5/Coqprime/Pmod.v +++ b/coqprime-8.4/Coqprime/Pmod.v @@ -6,8 +6,8 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export ZArith. -Require Export ZCmisc. +Require Export Coq.ZArith.ZArith. +Require Export Coqprime.ZCmisc. Open Local Scope positive_scope. @@ -392,7 +392,7 @@ Lemma gcd_log2_mod0 : Proof. intros a b c H;destruct c;simpl;rewrite H;trivial. Qed. -Require Import Zwf. +Require Import Coq.ZArith.Zwf. Lemma Zwf_pos : well_founded (fun x y => Zpos x < Zpos y). Proof. @@ -510,8 +510,8 @@ Proof. destruct (gcd_log2 b r r);intros;trivial. Qed. -Require Import ZArith. -Require Import Znumtheory. +Require Import Coq.ZArith.ZArith. +Require Import Coq.ZArith.Znumtheory. Hint Rewrite Zpos_mult times_Zmult square_Zmult Psucc_Zplus: zmisc. diff --git a/coqprime-8.5/Coqprime/Pocklington.v b/coqprime-8.4/Coqprime/Pocklington.v index 9871cd3e6..79e7dc616 100644 --- a/coqprime-8.5/Coqprime/Pocklington.v +++ b/coqprime-8.4/Coqprime/Pocklington.v @@ -6,14 +6,14 @@ (* 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. +Require Import Coq.ZArith.ZArith. +Require Export Coq.ZArith.Znumtheory. +Require Import Coqprime.Tactic. +Require Import Coqprime.ZCAux. +Require Import Coqprime.Zp. +Require Import Coqprime.FGroup. +Require Import Coqprime.EGroup. +Require Import Coqprime.Euler. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/PocklingtonCertificat.v b/coqprime-8.4/Coqprime/PocklingtonCertificat.v index ecf4462ed..fccea30b6 100644 --- a/coqprime-8.5/Coqprime/PocklingtonCertificat.v +++ b/coqprime-8.4/Coqprime/PocklingtonCertificat.v @@ -6,14 +6,14 @@ (* 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. +Require Import Coq.Lists.List. +Require Import Coq.ZArith.ZArith. +Require Import Coq.ZArith.Zorder. +Require Import Coqprime.ZCAux. +Require Import Coqprime.LucasLehmer. +Require Import Coqprime.Pocklington. +Require Import Coqprime.ZCmisc. +Require Import Coqprime.Pmod. Definition dec_prime := list (positive * positive). @@ -61,18 +61,18 @@ Definition mkProd (l:dec_prime) := (* [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 + | xH => (a mod n) | xO m' => let z := pow_mod a m' n in match z with | N0 => 0%N - | Npos z' => ((square z') mod n)%P + | Npos z' => ((square z') mod n) 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 + | Npos z' => ((square z') * a)%P mod n end end. @@ -118,7 +118,7 @@ Fixpoint pow_mod_pred (a:N) (l:dec_prime) (n:positive) {struct l} : N := | (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 + let a' := iter_pos (Ppred p) _ (fun x => Npow_mod x q n) a in pow_mod_pred a' l n end. @@ -332,113 +332,120 @@ 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). + generalize (iter_pos p Z (Z.mul 0) 1). induction p;simpl;trivial. Qed. +Opaque Zpower. +Opaque Zmult. + Lemma pow_Zpower : forall a p, Zpos (pow a p) = a ^ p. -Proof. - induction p; mauto; simpl; mauto; rewrite IHp; mauto. +Proof with mauto. + induction p;simpl... rewrite IHp... rewrite IHp... 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. +Proof with mauto. + induction m;simpl;intros... 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. + rewrite (Zmult_mod (a^m)); auto with zmisc. rewrite <- IHm. + destruct (pow_mod a m n);simpl... + rewrite Zmult_mod; auto with zmisc. + rewrite <- IHm. destruct (pow_mod a m n);simpl... 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. +Proof with mauto. + intros a p n;destruct a;simpl ... 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. + Z_of_N (iter_pos p N (fun x : N => Npow_mod x q n) a) = a^q^p mod n. +Proof with mauto. + induction p;simpl;intros ... + repeat rewrite IHp. rewrite (Zpower_mod ((a ^ q ^ p) ^ q ^ p));auto with zmisc. - rewrite (Zpower_mod (a ^ q ^ p)); mauto. - mauto. + rewrite (Zpower_mod (a ^ q ^ p))... + repeat rewrite IHp... Qed. -Hint Rewrite iter_Npow_mod_spec : zmisc. +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. +Proof with mauto. + unfold fold_pow_mod;induction l;simpl;intros ... + rewrite IHl... 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. +Proof with mauto. + unfold pow_mod_pred;induction l;simpl;intros ... + destruct a as (q,p);simpl. + destruct (p ?= 1)%P; rewrite IHl... 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. +Proof with mauto. + induction l;simpl;intros ... generalize (pos_eq_1_spec (snd a)); destruct (snd a ?= 1)%P;intros. - rewrite H; mauto. + rewrite H... replace (mkProd_pred l * (fst a * mkProd' l)) with (fst a *(mkProd_pred l * mkProd' l));try ring. - rewrite IHl; mauto. + rewrite IHl... 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. + replace ((snd a - 1)+1) with (Zpos (snd a)) ... + rewrite <- IHl;repeat rewrite Zmult_assoc ... destruct (snd a - 1);trivial. assert (1 < snd a); auto with zarith. Qed. -Hint Rewrite mkProd_pred_mkProd : zmisc. +Hint Rewrite mkProd_pred_mkProd : zmisc. Lemma lt_Zmod : forall p n, 0 <= p < n -> p mod n = p. -Proof. +Proof with mauto. 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. + apply Z_mod_lt... + destruct (mod_unique b (a/b) (a mod b) 0 a H0 H)... + rewrite <- Z_div_mod_eq... Qed. +Opaque Zminus. 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. +Proof with mauto. destruct p;intros;simpl. - rewrite <- Ppred_Zminus; auto. - apply Zmod_unique with (q := -1); mauto. + rewrite <- Ppred_Zminus... + change (-1) with (0 -1). rewrite <- (Z_mod_same n) ... + pattern 1 at 2;rewrite <- (lt_Zmod 1 n) ... + symmetry;apply lt_Zmod. +Transparent Zminus. + omega. 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). + rewrite H1 ... + unfold Z_of_N;rewrite <- Ppred_Zminus... + 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. +Proof with mauto. + intros; destruct x ... + destruct y;simpl ... Qed. Hint Rewrite times_mod_spec : zmisc. @@ -446,10 +453,10 @@ 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. +Proof with mauto. + induction l;simpl;intros... + destruct a as (q,p);simpl. + rewrite IHl... Qed. Lemma fold_aux : forall a N (n:positive) l prod, @@ -459,8 +466,8 @@ Lemma fold_aux : forall a N (n:positive) l prod, fold_left (fun (r : Z) (k : positive * positive) => r * (a^(N / fst k) - 1)) l prod mod n. -Proof. - induction l;simpl;intros; mauto. +Proof with mauto. + induction l;simpl;intros ... Qed. Lemma fst_all_pow_mod : @@ -472,12 +479,12 @@ Lemma fst_all_pow_mod : (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. +Proof with mauto. + induction l;simpl;intros... destruct a0 as (q,p);simpl. assert (Z_of_N A = A mod n). - rewrite H1; mauto. - rewrite (IHl (R * q)%positive); mauto; mauto. + rewrite H1 ... + rewrite (IHl (R * q)%positive)... pattern (q * mkProd' l) at 2;rewrite (Zmult_comm q). repeat rewrite Zmult_assoc. rewrite Z_div_mult;auto with zmisc zarith. @@ -488,11 +495,12 @@ Proof. 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. + rewrite (Zpower_mod (a^R));auto with zmisc. rewrite H1... + rewrite H3... + rewrite H1 ... Qed. + Lemma is_odd_Zodd : forall p, is_odd p = true -> Zodd p. Proof. destruct p;intros;simpl;trivial;discriminate. @@ -540,11 +548,11 @@ Ltac spec_dec := repeat match goal with | [H:(?x ?= ?y)%P = _ |- _] => generalize (is_eq_spec x y); - rewrite H;clear H; autorewrite with zmisc; + rewrite H;clear H;simpl; autorewrite with zmisc; intro | [H:(?x ?< ?y)%P = _ |- _] => generalize (is_lt_spec x y); - rewrite H; clear H; autorewrite with zmisc; + rewrite H; clear H;simpl; autorewrite with zmisc; intro end. @@ -568,7 +576,7 @@ Proof. 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. + rewrite H1;auto. intros (y,Heq). generalize H1 Heq;mauto. unfold Z_of_N. @@ -579,32 +587,32 @@ Proof. destruct y;discriminate Heq2. Qed. +Opaque Zplus Pplus. 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. +Proof with mauto. + induction l;simpl ... 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. + 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. + rewrite (prime_div_Zpower_prime p1 p p0)... apply (H0 (p0,p1));auto. - inversion H3; auto. - destruct IHl as (n,H3); mauto. - exists n; auto. + inversion H3... + destruct IHl as (n,H3)... + exists n... Qed. Lemma gcd_Zis_gcd : forall a b:positive, (Zis_gcd b a (gcd b a)%P). -Proof. +Proof with mauto. intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros. - generalize (div_eucl_spec b a); mauto. + 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. @@ -621,57 +629,53 @@ 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. +Proof with mauto. 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 ((Ppred N) / (mkProd dec))%P as (R1,n);simpl;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 ((R1 / xO (mkProd dec))%P) as (s,r');simpl;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. + (prod,aNm1);simpl... destruct prod as [|prod];try discriminate H0. destruct aNm1 as [|aNm1];try discriminate H0;elimif. - simpl in H3; simpl in H2. + simpl in H2;rewrite Zplus_0_r 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. + rewrite H2;rewrite H12 ... + rewrite <- Zpower_mult... clear H12. intros H14. match type of H14 with _ -> _ -> _ -> ?X => assert (H12:X); try apply H14; clear H14 - end; mauto. - rewrite Zmod_small; mauto. + end... + rewrite Zmod_small... assert (1 < mkProd dec). assert (H14 := Zlt_0_pos (mkProd dec)). - assert (1 <= mkProd dec); mauto. - destruct (Zle_lt_or_eq _ _ H15); mauto. + assert (1 <= mkProd dec)... + destruct (Zle_lt_or_eq _ _ H15)... 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. + apply Z_mod_lt ... + rewrite <- Z_div_mod_eq... rewrite H7. simpl;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. + rewrite H2;ring. + apply is_even_Zeven... + apply is_odd_Zodd... intros p; case p; clear p. intros HH; contradict HH. apply not_prime_0. @@ -688,7 +692,6 @@ Proof. 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)) @@ -697,9 +700,9 @@ Proof. 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. + ((1 * mkProd dec + 1) * (2 * mkProd dec * mkProd dec + (r - 1) * mkProd dec + 1))... rewrite <- H15;rewrite <- Heqr. - apply check_s_r_correct with sqrt; mauto. + apply check_s_r_correct with sqrt ... Qed. Lemma is_in_In : diff --git a/coqprime-8.5/Coqprime/Root.v b/coqprime-8.4/Coqprime/Root.v index 2f65790d6..4e74a4d2f 100644 --- a/coqprime-8.5/Coqprime/Root.v +++ b/coqprime-8.4/Coqprime/Root.v @@ -11,11 +11,11 @@ Proof that a polynomial has at most n roots ************************************************************************) -Require Import ZArith. -Require Import List. -Require Import UList. -Require Import Tactic. -Require Import Permutation. +Require Import Coq.ZArith.ZArith. +Require Import Coq.Lists.List. +Require Import Coqprime.UList. +Require Import Coqprime.Tactic. +Require Import Coqprime.Permutation. Open Scope Z_scope. @@ -33,8 +33,8 @@ 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) +| Zpos p => iter_pos p _ (plus one) zero +| Zneg p => op (iter_pos p _ (plus one) zero) end. Fixpoint eval (p: pol) (x: A) {struct p} : A := diff --git a/coqprime-8.5/Coqprime/Tactic.v b/coqprime-8.4/Coqprime/Tactic.v index 93a244149..93a244149 100644 --- a/coqprime-8.5/Coqprime/Tactic.v +++ b/coqprime-8.4/Coqprime/Tactic.v diff --git a/coqprime-8.5/Coqprime/UList.v b/coqprime-8.4/Coqprime/UList.v index 7b9d982ea..32ca6b2a0 100644 --- a/coqprime-8.5/Coqprime/UList.v +++ b/coqprime-8.4/Coqprime/UList.v @@ -7,33 +7,33 @@ (*************************************************************) (*********************************************************************** - UList.v - - Definition of list with distinct elements - - Definition: ulist + UList.v + + Definition of list with distinct elements + + Definition: ulist ************************************************************************) -Require Import List. -Require Import Arith. -Require Import Permutation. -Require Import ListSet. - +Require Import Coq.Lists.List. +Require Import Coq.Arith.Arith. +Require Import Coqprime.Permutation. +Require Import Coq.Lists.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 -> @@ -48,18 +48,16 @@ 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. +intros a l H l2 a0 H0 [H1|H1] H2; +inversion H0 as [|a1 l0 H3 H4 H5]; clear H0; auto; + subst; eauto using ulist_inv with datatypes. 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. @@ -68,13 +66,13 @@ 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. @@ -83,7 +81,7 @@ 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. @@ -103,7 +101,7 @@ 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)) ). @@ -112,7 +110,7 @@ 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) ). @@ -134,7 +132,7 @@ 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. @@ -150,7 +148,7 @@ 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). @@ -166,8 +164,8 @@ 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). @@ -180,14 +178,14 @@ 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 -> @@ -203,7 +201,7 @@ case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl; subst; auto. intros H4; case H4; auto. Qed. - + Theorem ulist_inv_ulist: forall (l : list A), ~ ulist l -> @@ -239,7 +237,7 @@ 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 -> @@ -253,11 +251,11 @@ 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). @@ -270,7 +268,7 @@ 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). diff --git a/coqprime-8.5/Coqprime/ZCAux.v b/coqprime-8.4/Coqprime/ZCAux.v index de03a2fe2..aa47fb655 100644 --- a/coqprime-8.5/Coqprime/ZCAux.v +++ b/coqprime-8.4/Coqprime/ZCAux.v @@ -12,10 +12,10 @@ Auxillary functions & Theorems **********************************************************************) -Require Import ArithRing. -Require Export ZArith Zpow_facts. -Require Export Znumtheory. -Require Export Tactic. +Require Import Coq.setoid_ring.ArithRing. +Require Export Coq.ZArith.ZArith Coq.ZArith.Zpow_facts. +Require Export Coq.ZArith.Znumtheory. +Require Export Coqprime.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. diff --git a/coqprime-8.5/Coqprime/ZCmisc.v b/coqprime-8.4/Coqprime/ZCmisc.v index c1bdacc63..e2ec66ba1 100644 --- a/coqprime-8.5/Coqprime/ZCmisc.v +++ b/coqprime-8.4/Coqprime/ZCmisc.v @@ -6,7 +6,7 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export ZArith. +Require Export Coq.ZArith.ZArith. Open Local Scope Z_scope. Coercion Zpos : positive >-> Z. diff --git a/coqprime-8.5/Coqprime/ZProgression.v b/coqprime-8.4/Coqprime/ZProgression.v index 51ce91cdc..4cf30d692 100644 --- a/coqprime-8.5/Coqprime/ZProgression.v +++ b/coqprime-8.4/Coqprime/ZProgression.v @@ -6,9 +6,9 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export Iterator. -Require Import ZArith. -Require Export UList. +Require Export Coqprime.Iterator. +Require Import Coq.ZArith.ZArith. +Require Export Coqprime.UList. Open Scope Z_scope. Theorem next_n_Z: forall n m, next_n Zsucc n m = n + Z_of_nat m. diff --git a/coqprime-8.5/Coqprime/ZSum.v b/coqprime-8.4/Coqprime/ZSum.v index 3a7f14065..907720f7c 100644 --- a/coqprime-8.5/Coqprime/ZSum.v +++ b/coqprime-8.4/Coqprime/ZSum.v @@ -9,12 +9,12 @@ (*********************************************************************** Summation.v from Z to Z *********************************************************************) -Require Import Arith. -Require Import ArithRing. -Require Import ListAux. -Require Import ZArith. -Require Import Iterator. -Require Import ZProgression. +Require Import Coq.Arith.Arith. +Require Import Coq.setoid_ring.ArithRing. +Require Import Coqprime.ListAux. +Require Import Coq.ZArith.ZArith. +Require Import Coqprime.Iterator. +Require Import Coqprime.ZProgression. Open Scope Z_scope. diff --git a/coqprime-8.5/Coqprime/Zp.v b/coqprime-8.4/Coqprime/Zp.v index 1e5295191..2f7d28d69 100644 --- a/coqprime-8.5/Coqprime/Zp.v +++ b/coqprime-8.4/Coqprime/Zp.v @@ -14,16 +14,16 @@ 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. +Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory Coq.ZArith.Zpow_facts. +Require Import Coqprime.Tactic. +Require Import Coq.Arith.Wf_nat. +Require Import Coqprime.UList. +Require Import Coqprime.FGroup. +Require Import Coqprime.EGroup. +Require Import Coqprime.IGroup. +Require Import Coqprime.Cyclic. +Require Import Coqprime.Euler. +Require Import Coqprime.ZProgression. Open Scope Z_scope. diff --git a/coqprime-8.5/Makefile b/coqprime-8.4/Makefile index c8e44a658..8fa838a1e 100644 --- a/coqprime-8.5/Makefile +++ b/coqprime-8.4/Makefile @@ -2,7 +2,7 @@ ## v # The Coq Proof Assistant ## ## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## ## \VV/ # ## -## // # Makefile automagically generated by coq_makefile V8.5pl1 ## +## // # Makefile automagically generated by coq_makefile V8.4pl6 ## ############################################################################# # WARNING @@ -19,10 +19,9 @@ .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. @@ -34,25 +33,14 @@ 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 +COQLIBS?= -R Coqprime Coqprime +COQDOCLIBS?=-R Coqprime Coqprime ########################## # # @@ -66,11 +54,10 @@ COQDEP?="$(COQBIN)coqdep" -c COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML) COQCHKFLAGS?=-silent -o COQDOCFLAGS?=-interpolate -utf8 -COQC?=$(TIMER) "$(COQBIN)coqc" +COQC?="$(COQBIN)coqc" GALLINA?="$(COQBIN)gallina" COQDOC?="$(COQBIN)coqdoc" COQCHK?="$(COQBIN)coqchk" -COQMKTOP?="$(COQBIN)coqmktop" ################## # # @@ -85,7 +72,6 @@ COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq else COQLIBINSTALL="${COQLIB}user-contrib" COQDOCINSTALL="${DOCDIR}user-contrib" -COQTOPINSTALL="${COQLIB}toploop" endif ###################### @@ -94,51 +80,40 @@ endif # # ###################### -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\ +VFILES:=Coqprime/Zp.v\ Coqprime/ZSum.v\ - Coqprime/Zp.v + Coqprime/ZProgression.v\ + Coqprime/ZCmisc.v\ + Coqprime/ZCAux.v\ + Coqprime/UList.v\ + Coqprime/Tactic.v\ + Coqprime/Root.v\ + Coqprime/PocklingtonCertificat.v\ + Coqprime/Pocklington.v\ + Coqprime/Pmod.v\ + Coqprime/Permutation.v\ + Coqprime/PGroup.v\ + Coqprime/NatAux.v\ + Coqprime/LucasLehmer.v\ + Coqprime/ListAux.v\ + Coqprime/Lagrange.v\ + Coqprime/Iterator.v\ + Coqprime/IGroup.v\ + Coqprime/FGroup.v\ + Coqprime/Euler.v\ + Coqprime/EGroup.v\ + Coqprime/Cyclic.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)) +VOFILES:=$(VFILES:.v=.vo) VOFILES1=$(patsubst Coqprime/%,%,$(filter Coqprime/%,$(VOFILES))) GLOBFILES:=$(VFILES:.v=.glob) +VIFILES:=$(VFILES:.v=.vi) 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 @@ -153,12 +128,8 @@ endif all: $(VOFILES) -quick: $(VOFILES:.vo=.vio) +spec: $(VIFILES) -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) @@ -189,7 +160,7 @@ beautify: $(VFILES:=.beautified) @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 +.PHONY: all opt byte archclean clean install userinstall depend html validate #################### # # @@ -207,7 +178,7 @@ userinstall: +$(MAKE) USERINSTALL=true install install: - cd "Coqprime" && for i in $(NATIVEFILES1) $(GLOBFILES1) $(VFILES1) $(VOFILES1); do \ + cd "Coqprime"; for i in $(VOFILES1); do \ install -d "`dirname "$(DSTROOT)"$(COQLIBINSTALL)/Coqprime/$$i`"; \ install -m 0644 $$i "$(DSTROOT)"$(COQLIBINSTALL)/Coqprime/$$i; \ done @@ -218,46 +189,12 @@ install-doc: 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) +clean: + rm -f $(VOFILES) $(VIFILES) $(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 + - rm -rf html mlihtml -cleanall:: clean - rm -f $(patsubst %.v,.%.aux,$(VFILES)) - -archclean:: +archclean: rm -f *.cmx *.o printenv: @@ -280,34 +217,31 @@ Makefile: _CoqProject # # ################### -$(VOFILES): %.vo: %.v - $(COQC) $(COQDEBUG) $(COQFLAGS) $* - -$(GLOBFILES): %.glob: %.v +%.vo %.glob: %.v $(COQC) $(COQDEBUG) $(COQFLAGS) $* -$(VFILES:.v=.vio): %.vio: %.v - $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $* +%.vi: %.v + $(COQC) -i $(COQDEBUG) $(COQFLAGS) $* -$(GFILES): %.g: %.v +%.g: %.v $(GALLINA) $< -$(VFILES:.v=.tex): %.tex: %.v +%.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ -$(HTMLFILES): %.html: %.v %.glob +%.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ -$(VFILES:.v=.g.tex): %.g.tex: %.v +%.g.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ -$(GHTMLFILES): %.g.html: %.v %.glob +%.g.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ -$(addsuffix .d,$(VFILES)): %.v.d: %.v - $(COQDEP) $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) +%.v.d: %.v + $(COQDEP) -slash $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) -$(addsuffix .beautified,$(VFILES)): %.v.beautified: +%.v.beautified: $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* # WARNING diff --git a/coqprime-8.4/README.md b/coqprime-8.4/README.md new file mode 100644 index 000000000..8f1b93b12 --- /dev/null +++ b/coqprime-8.4/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.4. It was generated from [coqprime_par.zip](https://gforge.inria.fr/frs/download.php/file/35201/coqprime_par.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.4/_CoqProject index 95b224864..95b224864 100644 --- a/coqprime-8.5/_CoqProject +++ b/coqprime-8.4/_CoqProject diff --git a/coqprime-8.5/README.md b/coqprime-8.5/README.md deleted file mode 100644 index 9c317fb00..000000000 --- a/coqprime-8.5/README.md +++ /dev/null @@ -1,9 +0,0 @@ -# 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/Coqprime/Cyclic.v b/coqprime/Coqprime/Cyclic.v index e2daa4d67..c25f683ca 100644 --- a/coqprime/Coqprime/Cyclic.v +++ b/coqprime/Coqprime/Cyclic.v @@ -11,13 +11,13 @@ Proof that an abelien ring is cyclic ************************************************************************) -Require Import Coqprime.ZCAux. -Require Import Coq.Lists.List. -Require Import Coqprime.Root. -Require Import Coqprime.UList. -Require Import Coqprime.IGroup. -Require Import Coqprime.EGroup. -Require Import Coqprime.FGroup. +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. diff --git a/coqprime/Coqprime/EGroup.v b/coqprime/Coqprime/EGroup.v index 553cb746c..933176abd 100644 --- a/coqprime/Coqprime/EGroup.v +++ b/coqprime/Coqprime/EGroup.v @@ -11,15 +11,15 @@ Given an element a, create the group {e, a, a^2, ..., a^n} **********************************************************************) -Require Import Coq.ZArith.ZArith. -Require Import Coqprime.Tactic. -Require Import Coq.Lists.List. -Require Import Coqprime.ZCAux. -Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. -Require Import Coq.Arith.Wf_nat. -Require Import Coqprime.UList. -Require Import Coqprime.FGroup. -Require Import Coqprime.Lagrange. +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. @@ -43,7 +43,7 @@ Hypothesis a_in_G: In a G.(s). **************************************) Set Implicit Arguments. -Definition gpow n := match n with Zpos p => iter_pos p _ (op a) G.(e) | _ => G.(e) end. +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). @@ -63,17 +63,17 @@ 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 p _ (op a) b = op (iter_pos p _ (op a) G.(e)) b. +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 p A x y)); auto. +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 p A x y)); auto. +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. @@ -87,7 +87,7 @@ 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 p2 A x y)); auto. +rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos A x y p2)); auto. exact (gpow_in (Zpos p2)). Qed. @@ -445,7 +445,7 @@ 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 p1 A (op a) (e G)) (s G)). +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. @@ -486,12 +486,12 @@ 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 p3 A (op a) (e G)) (s G)). +assert(H1: In (iter_pos A (op a) (e G) p3) (s G)). refine (gpow_in _ _ _ _ _ (Zpos p3)); auto. -assert(H2: In (iter_pos p3 A (op b) (e G)) (s G)). +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 p3 A x y) b); auto. +rewrite (fun x y => comm (iter_pos A x y p3) b); auto. rewrite (G.(assoc) a); try apply comm; auto. Qed. diff --git a/coqprime/Coqprime/Euler.v b/coqprime/Coqprime/Euler.v index e571d8e3c..06d92ce57 100644 --- a/coqprime/Coqprime/Euler.v +++ b/coqprime/Coqprime/Euler.v @@ -11,10 +11,10 @@ Definition of the Euler Totient function *************************************************************************) -Require Import Coq.ZArith.ZArith. -Require Export Coq.ZArith.Znumtheory. -Require Import Coqprime.Tactic. -Require Export Coqprime.ZSum. +Require Import ZArith. +Require Export Znumtheory. +Require Import Tactic. +Require Export ZSum. Open Scope Z_scope. diff --git a/coqprime/Coqprime/FGroup.v b/coqprime/Coqprime/FGroup.v index 0bcc9ebf1..a55710e7c 100644 --- a/coqprime/Coqprime/FGroup.v +++ b/coqprime/Coqprime/FGroup.v @@ -13,10 +13,10 @@ Definition: FGroup **********************************************************************) -Require Import Coq.Lists.List. -Require Import Coqprime.UList. -Require Import Coqprime.Tactic. -Require Import Coq.ZArith.ZArith. +Require Import List. +Require Import UList. +Require Import Tactic. +Require Import ZArith. Open Scope Z_scope. diff --git a/coqprime/Coqprime/IGroup.v b/coqprime/Coqprime/IGroup.v index 04219be5a..11a73d414 100644 --- a/coqprime/Coqprime/IGroup.v +++ b/coqprime/Coqprime/IGroup.v @@ -13,12 +13,12 @@ Definition: ZpGroup **********************************************************************) -Require Import Coq.ZArith.ZArith. -Require Import Coqprime.Tactic. -Require Import Coq.Arith.Wf_nat. -Require Import Coqprime.UList. -Require Import Coqprime.ListAux. -Require Import Coqprime.FGroup. +Require Import ZArith. +Require Import Tactic. +Require Import Wf_nat. +Require Import UList. +Require Import ListAux. +Require Import FGroup. Open Scope Z_scope. diff --git a/coqprime/Coqprime/Iterator.v b/coqprime/Coqprime/Iterator.v index e84687cd4..96d3e5655 100644 --- a/coqprime/Coqprime/Iterator.v +++ b/coqprime/Coqprime/Iterator.v @@ -6,9 +6,9 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export Coq.Lists.List. -Require Export Coqprime.Permutation. -Require Import Coq.Arith.Arith. +Require Export List. +Require Export Permutation. +Require Import Arith. Section Iterator. Variables A B : Set. diff --git a/coqprime/Coqprime/Lagrange.v b/coqprime/Coqprime/Lagrange.v index b890c5621..b35460bad 100644 --- a/coqprime/Coqprime/Lagrange.v +++ b/coqprime/Coqprime/Lagrange.v @@ -14,12 +14,12 @@ Definition: lagrange **********************************************************************) -Require Import Coq.Lists.List. -Require Import Coqprime.UList. -Require Import Coqprime.ListAux. -Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory. -Require Import Coqprime.NatAux. -Require Import Coqprime.FGroup. +Require Import List. +Require Import UList. +Require Import ListAux. +Require Import ZArith Znumtheory. +Require Import NatAux. +Require Import FGroup. Open Scope Z_scope. diff --git a/coqprime/Coqprime/ListAux.v b/coqprime/Coqprime/ListAux.v index 4ed154685..c3c9602bd 100644 --- a/coqprime/Coqprime/ListAux.v +++ b/coqprime/Coqprime/ListAux.v @@ -11,11 +11,11 @@ Auxillary functions & Theorems **********************************************************************) -Require Export Coq.Lists.List. -Require Export Coq.Arith.Arith. -Require Export Coqprime.Tactic. -Require Import Coq.Wellfounded.Inverse_Image. -Require Import Coq.Arith.Wf_nat. +Require Export List. +Require Export Arith. +Require Export Tactic. +Require Import Inverse_Image. +Require Import Wf_nat. (************************************** Some properties on list operators: app, map,... diff --git a/coqprime/Coqprime/LucasLehmer.v b/coqprime/Coqprime/LucasLehmer.v index c459195a8..a0e3b8e46 100644 --- a/coqprime/Coqprime/LucasLehmer.v +++ b/coqprime/Coqprime/LucasLehmer.v @@ -13,17 +13,17 @@ Definition: LucasLehmer **********************************************************************) -Require Import Coq.ZArith.ZArith. -Require Import Coqprime.ZCAux. -Require Import Coqprime.Tactic. -Require Import Coq.Arith.Wf_nat. -Require Import Coqprime.NatAux. -Require Import Coqprime.UList. -Require Import Coqprime.ListAux. -Require Import Coqprime.FGroup. -Require Import Coqprime.EGroup. -Require Import Coqprime.PGroup. -Require Import Coqprime.IGroup. +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. @@ -47,7 +47,7 @@ Qed. Definition of the power function for pairs p^n **************************************) -Definition ppow p n := match n with Zpos q => iter_pos q _ (pmult p) (1, 0) | _ => (1, 0) end. +Definition ppow p n := match n with Zpos q => iter_pos _ (pmult p) (1, 0) q | _ => (1, 0) end. (************************************** Some properties of ppow @@ -63,14 +63,14 @@ 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 p _ (pmult a) b = pmult (iter_pos p _ (pmult a) (1, 0)) b. +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 p _ x y)); auto. +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 p _ x y)); auto. +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. @@ -114,7 +114,7 @@ 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 p3 _ x y) p); auto. +rewrite (fun x y => pmult_comm (iter_pos _ x y p3) p); auto. rewrite (pmult_assoc m); try apply pmult_comm; auto. Qed. @@ -490,13 +490,13 @@ End Lucas. Definition SS p := let n := Mp p in match p - 2 with - Zpos p1 => iter_pos p1 _ (fun x => Zmodd (Zsquare x - 2) n) (Zmodd 4 n) + 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 p _ (fun x => Zmodd (Zsquare x - 2) z1) z2 = fst (s (n + Zpos p)) 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. diff --git a/coqprime/Coqprime/NatAux.v b/coqprime/Coqprime/NatAux.v index 6df511eed..eab09150c 100644 --- a/coqprime/Coqprime/NatAux.v +++ b/coqprime/Coqprime/NatAux.v @@ -11,7 +11,7 @@ Auxillary functions & Theorems **********************************************************************) -Require Export Coq.Arith.Arith. +Require Export Arith. (************************************** Some properties of minus diff --git a/coqprime/Coqprime/PGroup.v b/coqprime/Coqprime/PGroup.v index 19eff5850..e9c1b2f47 100644 --- a/coqprime/Coqprime/PGroup.v +++ b/coqprime/Coqprime/PGroup.v @@ -14,15 +14,15 @@ Definition: PGroup **********************************************************************) -Require Import Coq.ZArith.ZArith. -Require Import Coq.ZArith.Znumtheory. -Require Import Coqprime.Tactic. -Require Import Coq.Arith.Wf_nat. -Require Import Coqprime.ListAux. -Require Import Coqprime.UList. -Require Import Coqprime.FGroup. -Require Import Coqprime.EGroup. -Require Import Coqprime.IGroup. +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. diff --git a/coqprime/Coqprime/Permutation.v b/coqprime/Coqprime/Permutation.v index 7cb6f629d..a06693f89 100644 --- a/coqprime/Coqprime/Permutation.v +++ b/coqprime/Coqprime/Permutation.v @@ -11,8 +11,8 @@ Defintion and properties of permutations **********************************************************************) -Require Export Coq.Lists.List. -Require Export Coqprime.ListAux. +Require Export List. +Require Export ListAux. Section permutation. Variable A : Set. diff --git a/coqprime/Coqprime/Pmod.v b/coqprime/Coqprime/Pmod.v index 45961896e..f64af48e3 100644 --- a/coqprime/Coqprime/Pmod.v +++ b/coqprime/Coqprime/Pmod.v @@ -6,8 +6,8 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export Coq.ZArith.ZArith. -Require Export Coqprime.ZCmisc. +Require Export ZArith. +Require Export ZCmisc. Open Local Scope positive_scope. @@ -392,7 +392,7 @@ Lemma gcd_log2_mod0 : Proof. intros a b c H;destruct c;simpl;rewrite H;trivial. Qed. -Require Import Coq.ZArith.Zwf. +Require Import Zwf. Lemma Zwf_pos : well_founded (fun x y => Zpos x < Zpos y). Proof. @@ -510,8 +510,8 @@ Proof. destruct (gcd_log2 b r r);intros;trivial. Qed. -Require Import Coq.ZArith.ZArith. -Require Import Coq.ZArith.Znumtheory. +Require Import ZArith. +Require Import Znumtheory. Hint Rewrite Zpos_mult times_Zmult square_Zmult Psucc_Zplus: zmisc. diff --git a/coqprime/Coqprime/Pocklington.v b/coqprime/Coqprime/Pocklington.v index 79e7dc616..9871cd3e6 100644 --- a/coqprime/Coqprime/Pocklington.v +++ b/coqprime/Coqprime/Pocklington.v @@ -6,14 +6,14 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Import Coq.ZArith.ZArith. -Require Export Coq.ZArith.Znumtheory. -Require Import Coqprime.Tactic. -Require Import Coqprime.ZCAux. -Require Import Coqprime.Zp. -Require Import Coqprime.FGroup. -Require Import Coqprime.EGroup. -Require Import Coqprime.Euler. +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. diff --git a/coqprime/Coqprime/PocklingtonCertificat.v b/coqprime/Coqprime/PocklingtonCertificat.v index fccea30b6..ecf4462ed 100644 --- a/coqprime/Coqprime/PocklingtonCertificat.v +++ b/coqprime/Coqprime/PocklingtonCertificat.v @@ -6,14 +6,14 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Import Coq.Lists.List. -Require Import Coq.ZArith.ZArith. -Require Import Coq.ZArith.Zorder. -Require Import Coqprime.ZCAux. -Require Import Coqprime.LucasLehmer. -Require Import Coqprime.Pocklington. -Require Import Coqprime.ZCmisc. -Require Import Coqprime.Pmod. +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). @@ -61,18 +61,18 @@ Definition mkProd (l:dec_prime) := (* [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) + | 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) + | 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 + | Npos z' => (((square z') * a)%P mod n)%P end end. @@ -118,7 +118,7 @@ Fixpoint pow_mod_pred (a:N) (l:dec_prime) (n:positive) {struct l} : N := | (q,p)::l => if (p ?= 1) then pow_mod_pred a l n else - let a' := iter_pos (Ppred p) _ (fun x => Npow_mod x q n) a in + let a' := iter_pos _ (fun x => Npow_mod x q n) a (Ppred p) in pow_mod_pred a' l n end. @@ -332,120 +332,113 @@ 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 p Z (Z.mul 0) 1). + generalize (iter_pos Z (Z.mul 0) 1 p). induction p;simpl;trivial. Qed. -Opaque Zpower. -Opaque Zmult. - Lemma pow_Zpower : forall a p, Zpos (pow a p) = a ^ p. -Proof with mauto. - induction p;simpl... rewrite IHp... rewrite IHp... +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 with mauto. - induction m;simpl;intros... +Proof. + induction m; mauto; simpl; intros; mauto. rewrite Zmult_mod; auto with zmisc. - rewrite (Zmult_mod (a^m)); auto with zmisc. rewrite <- IHm. - destruct (pow_mod a m n);simpl... - rewrite Zmult_mod; auto with zmisc. - rewrite <- IHm. destruct (pow_mod a m n);simpl... + 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 with mauto. - intros a p n;destruct a;simpl ... +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 p N (fun x : N => Npow_mod x q n) a) = a^q^p mod n. -Proof with mauto. - induction p;simpl;intros ... - repeat rewrite IHp. + 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))... - repeat rewrite IHp... + rewrite (Zpower_mod (a ^ q ^ p)); mauto. + mauto. Qed. -Hint Rewrite iter_Npow_mod_spec : zmisc. - +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 with mauto. - unfold fold_pow_mod;induction l;simpl;intros ... - rewrite IHl... +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 with mauto. - unfold pow_mod_pred;induction l;simpl;intros ... - destruct a as (q,p);simpl. - destruct (p ?= 1)%P; rewrite IHl... +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 with mauto. - induction l;simpl;intros ... +Proof. + induction l;simpl;intros; mauto. generalize (pos_eq_1_spec (snd a)); destruct (snd a ?= 1)%P;intros. - rewrite H... + rewrite H; mauto. replace (mkProd_pred l * (fst a * mkProd' l)) with (fst a *(mkProd_pred l * mkProd' l));try ring. - rewrite IHl... + 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)) ... - rewrite <- IHl;repeat rewrite Zmult_assoc ... + 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. +Hint Rewrite mkProd_pred_mkProd : zmisc. Lemma lt_Zmod : forall p n, 0 <= p < n -> p mod n = p. -Proof with mauto. +Proof. intros a b H. assert ( 0 <= a mod b < b). - apply Z_mod_lt... - destruct (mod_unique b (a/b) (a mod b) 0 a H0 H)... - rewrite <- Z_div_mod_eq... + 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. -Opaque Zminus. 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 with mauto. +Proof. destruct p;intros;simpl. - rewrite <- Ppred_Zminus... - change (-1) with (0 -1). rewrite <- (Z_mod_same n) ... - pattern 1 at 2;rewrite <- (lt_Zmod 1 n) ... - symmetry;apply lt_Zmod. -Transparent Zminus. - omega. + rewrite <- Ppred_Zminus; auto. + apply Zmod_unique with (q := -1); mauto. assert (H1 := pos_eq_1_spec p);destruct (p?=1)%P. - rewrite H1 ... - unfold Z_of_N;rewrite <- Ppred_Zminus... - simpl in H;symmetry; apply (lt_Zmod (p-1) n)... + 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 with mauto. - intros; destruct x ... - destruct y;simpl ... +Proof. + intros; destruct x; mauto. + destruct y;simpl; mauto. Qed. Hint Rewrite times_mod_spec : zmisc. @@ -453,10 +446,10 @@ 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 with mauto. - induction l;simpl;intros... - destruct a as (q,p);simpl. - rewrite IHl... +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, @@ -466,8 +459,8 @@ Lemma fold_aux : forall a N (n:positive) l prod, fold_left (fun (r : Z) (k : positive * positive) => r * (a^(N / fst k) - 1)) l prod mod n. -Proof with mauto. - induction l;simpl;intros ... +Proof. + induction l;simpl;intros; mauto. Qed. Lemma fst_all_pow_mod : @@ -479,12 +472,12 @@ Lemma fst_all_pow_mod : (fold_left (fun r (k:positive*positive) => (r * (a ^ (R* mkProd' l / (fst k)) - 1))) l prod) mod n. -Proof with mauto. - induction l;simpl;intros... +Proof. + induction l;simpl;intros; mauto. destruct a0 as (q,p);simpl. assert (Z_of_N A = A mod n). - rewrite H1 ... - rewrite (IHl (R * q)%positive)... + 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. @@ -495,12 +488,11 @@ Proof with mauto. 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... - rewrite H3... - rewrite H1 ... + 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. @@ -548,11 +540,11 @@ Ltac spec_dec := repeat match goal with | [H:(?x ?= ?y)%P = _ |- _] => generalize (is_eq_spec x y); - rewrite H;clear H;simpl; autorewrite with zmisc; + rewrite H;clear H; autorewrite with zmisc; intro | [H:(?x ?< ?y)%P = _ |- _] => generalize (is_lt_spec x y); - rewrite H; clear H;simpl; autorewrite with zmisc; + rewrite H; clear H; autorewrite with zmisc; intro end. @@ -576,7 +568,7 @@ Proof. assert (Zpos (xO (xO (xO s))) = 8 * s). repeat rewrite Zpos_xO_add;ring. generalizeclear H1; rewrite H2;mauto;intros. apply (not_square sqrt). - rewrite H1;auto. + simpl Z.of_N; rewrite H1;auto. intros (y,Heq). generalize H1 Heq;mauto. unfold Z_of_N. @@ -587,32 +579,32 @@ Proof. destruct y;discriminate Heq2. Qed. -Opaque Zplus Pplus. 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 with mauto. - induction l;simpl ... +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. + 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)... + rewrite (prime_div_Zpower_prime p1 p p0); mauto. apply (H0 (p0,p1));auto. - inversion H3... - destruct IHl as (n,H3)... - exists n... + 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 with mauto. +Proof. intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros. - generalize (div_eucl_spec b a)... + 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. @@ -629,53 +621,57 @@ 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 with mauto. +Proof. unfold test_pock;intros. elimif. generalize (div_eucl_spec (Ppred N) (mkProd dec)); - destruct ((Ppred N) / (mkProd dec))%P as (R1,n);simpl;mauto;intros (H2,H3). + 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');simpl;mauto;intros (H7,H8). + 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);simpl... + (prod,aNm1); mauto; simpl Z_of_N. destruct prod as [|prod];try discriminate H0. destruct aNm1 as [|aNm1];try discriminate H0;elimif. - simpl in H2;rewrite Zplus_0_r in H2. + 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. - rewrite H2;rewrite H12 ... - rewrite <- Zpower_mult... + 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... - rewrite Zmod_small... + end; mauto. + rewrite Zmod_small; mauto. assert (1 < mkProd dec). assert (H14 := Zlt_0_pos (mkProd dec)). - assert (1 <= mkProd dec)... - destruct (Zle_lt_or_eq _ _ H15)... + 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. - apply Z_mod_lt ... - rewrite <- Z_div_mod_eq... rewrite H7. simpl;ring. + 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;ring. - apply is_even_Zeven... - apply is_odd_Zodd... + 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. @@ -692,6 +688,7 @@ Proof with mauto. 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)) @@ -700,9 +697,9 @@ Proof with mauto. 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))... + ((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 ... + apply check_s_r_correct with sqrt; mauto. Qed. Lemma is_in_In : diff --git a/coqprime/Coqprime/Root.v b/coqprime/Coqprime/Root.v index 4e74a4d2f..2f65790d6 100644 --- a/coqprime/Coqprime/Root.v +++ b/coqprime/Coqprime/Root.v @@ -11,11 +11,11 @@ Proof that a polynomial has at most n roots ************************************************************************) -Require Import Coq.ZArith.ZArith. -Require Import Coq.Lists.List. -Require Import Coqprime.UList. -Require Import Coqprime.Tactic. -Require Import Coqprime.Permutation. +Require Import ZArith. +Require Import List. +Require Import UList. +Require Import Tactic. +Require Import Permutation. Open Scope Z_scope. @@ -33,8 +33,8 @@ Let pol := list A. Definition toA z := match z with Z0 => zero -| Zpos p => iter_pos p _ (plus one) zero -| Zneg p => op (iter_pos p _ (plus one) 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 := diff --git a/coqprime/Coqprime/UList.v b/coqprime/Coqprime/UList.v index 32ca6b2a0..7b9d982ea 100644 --- a/coqprime/Coqprime/UList.v +++ b/coqprime/Coqprime/UList.v @@ -7,33 +7,33 @@ (*************************************************************) (*********************************************************************** - UList.v - - Definition of list with distinct elements - - Definition: ulist + UList.v + + Definition of list with distinct elements + + Definition: ulist ************************************************************************) -Require Import Coq.Lists.List. -Require Import Coq.Arith.Arith. -Require Import Coqprime.Permutation. -Require Import Coq.Lists.ListSet. - +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 -> @@ -48,16 +48,18 @@ 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]; clear H0; auto; - subst; eauto using ulist_inv with datatypes. +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. @@ -66,13 +68,13 @@ 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. @@ -81,7 +83,7 @@ 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. @@ -101,7 +103,7 @@ 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)) ). @@ -110,7 +112,7 @@ 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) ). @@ -132,7 +134,7 @@ 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. @@ -148,7 +150,7 @@ 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). @@ -164,8 +166,8 @@ 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). @@ -178,14 +180,14 @@ 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 -> @@ -201,7 +203,7 @@ case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl; subst; auto. intros H4; case H4; auto. Qed. - + Theorem ulist_inv_ulist: forall (l : list A), ~ ulist l -> @@ -237,7 +239,7 @@ 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 -> @@ -251,11 +253,11 @@ 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). @@ -268,7 +270,7 @@ 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). diff --git a/coqprime/Coqprime/ZCAux.v b/coqprime/Coqprime/ZCAux.v index aa47fb655..de03a2fe2 100644 --- a/coqprime/Coqprime/ZCAux.v +++ b/coqprime/Coqprime/ZCAux.v @@ -12,10 +12,10 @@ Auxillary functions & Theorems **********************************************************************) -Require Import Coq.setoid_ring.ArithRing. -Require Export Coq.ZArith.ZArith Coq.ZArith.Zpow_facts. -Require Export Coq.ZArith.Znumtheory. -Require Export Coqprime.Tactic. +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. diff --git a/coqprime/Coqprime/ZCmisc.v b/coqprime/Coqprime/ZCmisc.v index e2ec66ba1..c1bdacc63 100644 --- a/coqprime/Coqprime/ZCmisc.v +++ b/coqprime/Coqprime/ZCmisc.v @@ -6,7 +6,7 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export Coq.ZArith.ZArith. +Require Export ZArith. Open Local Scope Z_scope. Coercion Zpos : positive >-> Z. diff --git a/coqprime/Coqprime/ZProgression.v b/coqprime/Coqprime/ZProgression.v index 4cf30d692..51ce91cdc 100644 --- a/coqprime/Coqprime/ZProgression.v +++ b/coqprime/Coqprime/ZProgression.v @@ -6,9 +6,9 @@ (* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) (*************************************************************) -Require Export Coqprime.Iterator. -Require Import Coq.ZArith.ZArith. -Require Export Coqprime.UList. +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. diff --git a/coqprime/Coqprime/ZSum.v b/coqprime/Coqprime/ZSum.v index 907720f7c..3a7f14065 100644 --- a/coqprime/Coqprime/ZSum.v +++ b/coqprime/Coqprime/ZSum.v @@ -9,12 +9,12 @@ (*********************************************************************** Summation.v from Z to Z *********************************************************************) -Require Import Coq.Arith.Arith. -Require Import Coq.setoid_ring.ArithRing. -Require Import Coqprime.ListAux. -Require Import Coq.ZArith.ZArith. -Require Import Coqprime.Iterator. -Require Import Coqprime.ZProgression. +Require Import Arith. +Require Import ArithRing. +Require Import ListAux. +Require Import ZArith. +Require Import Iterator. +Require Import ZProgression. Open Scope Z_scope. diff --git a/coqprime/Coqprime/Zp.v b/coqprime/Coqprime/Zp.v index 2f7d28d69..1e5295191 100644 --- a/coqprime/Coqprime/Zp.v +++ b/coqprime/Coqprime/Zp.v @@ -14,16 +14,16 @@ Definition: ZpGroup **********************************************************************) -Require Import Coq.ZArith.ZArith Coq.ZArith.Znumtheory Coq.ZArith.Zpow_facts. -Require Import Coqprime.Tactic. -Require Import Coq.Arith.Wf_nat. -Require Import Coqprime.UList. -Require Import Coqprime.FGroup. -Require Import Coqprime.EGroup. -Require Import Coqprime.IGroup. -Require Import Coqprime.Cyclic. -Require Import Coqprime.Euler. -Require Import Coqprime.ZProgression. +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. diff --git a/coqprime/Makefile b/coqprime/Makefile index 8fa838a1e..c8e44a658 100644 --- a/coqprime/Makefile +++ b/coqprime/Makefile @@ -2,7 +2,7 @@ ## v # The Coq Proof Assistant ## ## <O___,, # INRIA - CNRS - LIX - LRI - PPS ## ## \VV/ # ## -## // # Makefile automagically generated by coq_makefile V8.4pl6 ## +## // # Makefile automagically generated by coq_makefile V8.5pl1 ## ############################################################################# # WARNING @@ -19,9 +19,10 @@ .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. @@ -33,14 +34,25 @@ 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 +COQLIBS?=\ + -R "Coqprime" Coqprime +COQDOCLIBS?=\ + -R "Coqprime" Coqprime ########################## # # @@ -54,10 +66,11 @@ COQDEP?="$(COQBIN)coqdep" -c COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML) COQCHKFLAGS?=-silent -o COQDOCFLAGS?=-interpolate -utf8 -COQC?="$(COQBIN)coqc" +COQC?=$(TIMER) "$(COQBIN)coqc" GALLINA?="$(COQBIN)gallina" COQDOC?="$(COQBIN)coqdoc" COQCHK?="$(COQBIN)coqchk" +COQMKTOP?="$(COQBIN)coqmktop" ################## # # @@ -72,6 +85,7 @@ COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq else COQLIBINSTALL="${COQLIB}user-contrib" COQDOCINSTALL="${DOCDIR}user-contrib" +COQTOPINSTALL="${COQLIB}toploop" endif ###################### @@ -80,40 +94,51 @@ endif # # ###################### -VFILES:=Coqprime/Zp.v\ - Coqprime/ZSum.v\ - Coqprime/ZProgression.v\ - Coqprime/ZCmisc.v\ - Coqprime/ZCAux.v\ - Coqprime/UList.v\ - Coqprime/Tactic.v\ - Coqprime/Root.v\ - Coqprime/PocklingtonCertificat.v\ - Coqprime/Pocklington.v\ - Coqprime/Pmod.v\ - Coqprime/Permutation.v\ - Coqprime/PGroup.v\ - Coqprime/NatAux.v\ - Coqprime/LucasLehmer.v\ - Coqprime/ListAux.v\ - Coqprime/Lagrange.v\ - Coqprime/Iterator.v\ - Coqprime/IGroup.v\ - Coqprime/FGroup.v\ - Coqprime/Euler.v\ +VFILES:=Coqprime/Cyclic.v\ Coqprime/EGroup.v\ - Coqprime/Cyclic.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)) -VOFILES:=$(VFILES:.v=.vo) +VO=vo +VOFILES:=$(VFILES:.v=.$(VO)) VOFILES1=$(patsubst Coqprime/%,%,$(filter Coqprime/%,$(VOFILES))) GLOBFILES:=$(VFILES:.v=.glob) -VIFILES:=$(VFILES:.v=.vi) 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 @@ -128,8 +153,12 @@ endif all: $(VOFILES) -spec: $(VIFILES) +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) @@ -160,7 +189,7 @@ beautify: $(VFILES:=.beautified) @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 opt byte archclean clean install userinstall depend html validate +.PHONY: all archclean beautify byte clean cleanall gallina gallinahtml html install install-doc install-natdynlink install-toploop opt printenv quick uninstall userinstall validate vio2vo #################### # # @@ -178,7 +207,7 @@ userinstall: +$(MAKE) USERINSTALL=true install install: - cd "Coqprime"; for i in $(VOFILES1); do \ + 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 @@ -189,12 +218,46 @@ install-doc: install -m 0644 $$i "$(DSTROOT)"$(COQDOCINSTALL)/Coqprime/$$i;\ done -clean: - rm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old) +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 + - rm -rf html mlihtml uninstall_me.sh -archclean: +cleanall:: clean + rm -f $(patsubst %.v,.%.aux,$(VFILES)) + +archclean:: rm -f *.cmx *.o printenv: @@ -217,31 +280,34 @@ Makefile: _CoqProject # # ################### -%.vo %.glob: %.v +$(VOFILES): %.vo: %.v + $(COQC) $(COQDEBUG) $(COQFLAGS) $* + +$(GLOBFILES): %.glob: %.v $(COQC) $(COQDEBUG) $(COQFLAGS) $* -%.vi: %.v - $(COQC) -i $(COQDEBUG) $(COQFLAGS) $* +$(VFILES:.v=.vio): %.vio: %.v + $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $* -%.g: %.v +$(GFILES): %.g: %.v $(GALLINA) $< -%.tex: %.v +$(VFILES:.v=.tex): %.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ -%.html: %.v %.glob +$(HTMLFILES): %.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html $< -o $@ -%.g.tex: %.v +$(VFILES:.v=.g.tex): %.g.tex: %.v $(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ -%.g.html: %.v %.glob +$(GHTMLFILES): %.g.html: %.v %.glob $(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ -%.v.d: %.v - $(COQDEP) -slash $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) +$(addsuffix .d,$(VFILES)): %.v.d: %.v + $(COQDEP) $(COQLIBS) "$<" > "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) -%.v.beautified: +$(addsuffix .beautified,$(VFILES)): %.v.beautified: $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* # WARNING diff --git a/coqprime/README.md b/coqprime/README.md index 8f1b93b12..9c317fb00 100644 --- a/coqprime/README.md +++ b/coqprime/README.md @@ -1,6 +1,6 @@ # Coqprime (LGPL subset) -This is a mirror of the LGPL-licensed and autogenerated files from [Coqprime](http://coqprime.gforge.inria.fr/) for Coq 8.4. It was generated from [coqprime_par.zip](https://gforge.inria.fr/frs/download.php/file/35201/coqprime_par.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. +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 diff --git a/etc/coq-scripts b/etc/coq-scripts new file mode 160000 +Subproject d858db1f3a64ea683e46204d0d8f775c5dbff97 diff --git a/src/Algebra.v b/src/Algebra.v new file mode 100644 index 000000000..ecc5e4209 --- /dev/null +++ b/src/Algebra.v @@ -0,0 +1,740 @@ +Require Import Coq.Classes.Morphisms. Require Coq.Setoids.Setoid. +Require Import Crypto.Util.Tactics Crypto.Tactics.Nsatz. +Require Import Crypto.Util.Decidable. +Local Close Scope nat_scope. Local Close Scope type_scope. Local Close Scope core_scope. + +Notation is_eq_dec := (DecidableRel _) (only parsing). +Notation "@ 'is_eq_dec' T R" := (DecidableRel (R:T->T->Prop)) + (at level 10, T at level 8, R at level 8, only parsing). +Notation eq_dec x y := (@dec (_ x y) _) (only parsing). + +Section Algebra. + Context {T:Type} {eq:T->T->Prop}. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + + Local Notation is_eq_dec := (@is_eq_dec T eq). + + 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. + + Lemma neq_inv_nonzero : forall x, x <> inv x -> x <> id. + Proof. + intros ? Hx Hi; apply Hx. + rewrite Hi. + symmetry; apply inv_id. + Qed. + + Lemma inv_neq_nonzero : forall x, inv x <> x -> x <> id. + Proof. + intros ? Hx Hi; apply Hx. + rewrite Hi. + apply inv_id. + 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. + + Section GroupByHomomorphism. + Lemma surjective_homomorphism_from_group + {G EQ OP ID INV} {groupG:@group G EQ OP ID INV} + {H eq op id inv} + {Equivalence_eq: @Equivalence H eq} {eq_dec: forall x y, {eq x y} + {~ eq x y}} + {Proper_op:Proper(eq==>eq==>eq)op} + {Proper_inv:Proper(eq==>eq)inv} + {phi iph} {Proper_phi:Proper(EQ==>eq)phi} {Proper_iph:Proper(eq==>EQ)iph} + {surj:forall h, phi (iph h) = h} + {phi_op : forall a b, eq (phi (OP a b)) (op (phi a) (phi b))} + {phi_inv : forall a, eq (phi (INV a)) (inv (phi a))} + {phi_id : eq (phi ID) id} + : @group H eq op id inv. + Proof. + repeat split; eauto with core typeclass_instances; intros; + repeat match goal with + |- context[?x] => + match goal with + | |- context[iph x] => fail 1 + | _ => unify x id; fail 1 + | _ => is_var x; rewrite <- (surj x) + end + end; + repeat rewrite <-?phi_op, <-?phi_inv, <-?phi_id; + f_equiv; auto using associative, left_identity, right_identity, left_inverse, right_inverse. + Qed. + + Lemma isomorphism_to_subgroup_group + {G EQ OP ID INV} + {Equivalence_EQ: @Equivalence G EQ} {eq_dec: forall x y, {EQ x y} + {~ EQ x y}} + {Proper_OP:Proper(EQ==>EQ==>EQ)OP} + {Proper_INV:Proper(EQ==>EQ)INV} + {H eq op id inv} {groupG:@group H eq op id inv} + {phi} + {eq_phi_EQ: forall x y, eq (phi x) (phi y) -> EQ x y} + {phi_op : forall a b, eq (phi (OP a b)) (op (phi a) (phi b))} + {phi_inv : forall a, eq (phi (INV a)) (inv (phi a))} + {phi_id : eq (phi ID) id} + : @group G EQ OP ID INV. + Proof. + repeat split; eauto with core typeclass_instances; intros; + eapply eq_phi_EQ; + repeat rewrite ?phi_op, ?phi_inv, ?phi_id; + auto using associative, left_identity, right_identity, left_inverse, right_inverse. + Qed. + End GroupByHomomorphism. +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. + + Lemma mul_nonzero_nonzero_iff (x y : T) + : ~eq (mul x y) zero <-> ~eq x zero /\ ~eq y zero. + Proof. + split. + { intro H0; split; intro H1; apply H0; rewrite H1. + { apply Ring.mul_0_r. } + { apply Ring.mul_0_l. } } + { intros [? ?] ?; edestruct mul_nonzero_nonzero_cases; eauto with nocore. } + 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. + +(*** Inequalities over fields *) +Ltac assert_expr_by_nsatz H ty := + let H' := fresh in + rename H into H'; assert (H : ty) + by (try (intro; apply H'); nsatz); + clear H'. +Ltac test_not_constr_eq_assert_expr_by_nsatz y zero H ty := + first [ constr_eq y zero; fail 1 y "is already" zero + | assert_expr_by_nsatz H ty ]. +Ltac canonicalize_field_inequalities_step' eq zero opp add sub := + match goal with + | [ H : not (eq ?x (opp ?y)) |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (not (eq (add x y) zero)) + | [ H : (eq ?x (opp ?y) -> False)%type |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (eq (add x y) zero -> False)%type + | [ H : not (eq ?x ?y) |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (not (eq (sub x y) zero)) + | [ H : (eq ?x ?y -> False)%type |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (not (eq (sub x y) zero)) + end. +Ltac canonicalize_field_inequalities' eq zero opp add sub := repeat canonicalize_field_inequalities_step' eq zero opp add sub. +Ltac canonicalize_field_equalities_step' eq zero opp add sub := + lazymatch goal with + | [ H : eq ?x (opp ?y) |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (eq (add x y) zero) + | [ H : eq ?x ?y |- _ ] + => test_not_constr_eq_assert_expr_by_nsatz y zero H (eq (sub x y) zero) + end. +Ltac canonicalize_field_equalities' eq zero opp add sub := repeat canonicalize_field_equalities_step' eq zero opp add sub. + +(** These are the two user-facing tactics. They put (in)equalities + into the form [_ <> 0] / [_ = 0]. *) +Ltac canonicalize_field_inequalities := + let fld := guess_field in + lazymatch type of fld with + | @field ?F ?eq ?zero ?one ?opp ?add ?sub ?mul ?inv ?div + => canonicalize_field_inequalities' eq zero opp add sub + end. +Ltac canonicalize_field_equalities := + let fld := guess_field in + lazymatch type of fld with + | @field ?F ?eq ?zero ?one ?opp ?add ?sub ?mul ?inv ?div + => canonicalize_field_equalities' eq zero opp add sub + end. + + +(*** 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 ExtraLemmas. + Context {F eq 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. + Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope. + + Lemma only_two_square_roots' x y : x * x = y * y -> x <> y -> x <> opp y -> False. + Proof. + intros. + canonicalize_field_equalities; canonicalize_field_inequalities. + assert (H' : (x + y) * (x - y) <> 0) by (apply mul_nonzero_nonzero; assumption). + apply H'; nsatz. + Qed. + + Lemma only_two_square_roots x y z : x * x = z -> y * y = z -> x <> y -> x <> opp y -> False. + Proof. + intros; setoid_subst z; eauto using only_two_square_roots'. + Qed. +End ExtraLemmas. + +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/Assembly/AlmostConversion.v b/src/Assembly/AlmostConversion.v new file mode 100644 index 000000000..878aa37bf --- /dev/null +++ b/src/Assembly/AlmostConversion.v @@ -0,0 +1,64 @@ + +Require Import NArith. +Require Export Qhasm AlmostQhasm Conversion. + +Module AlmostConversion <: Conversion AlmostQhasm Qhasm. + Import QhasmCommon AlmostQhasm Qhasm. + Import ListNotations. + + Fixpoint almostToQhasm' (prog: AlmostProgram) (lblStart: N): list QhasmStatement := + let label0 := (lblStart * 2)%N in + let label1 := (label0 + 1)%N in + + match prog with + | ASkip => [] + | ASeq a b => (almostToQhasm' a label0) ++ (almostToQhasm' b label1) + | AAssign a => [ QAssign a ] + | AOp a => [ QOp a ] + | ACond c a b => + let start := N.shiftl 2 label0 in + let finish := (start + 1)%N in + [QCond c (N.to_nat start)] ++ + (almostToQhasm' b (start + 2)) ++ + [QCond CTrue (N.to_nat finish)] ++ + [QLabel (N.to_nat start)] ++ + (almostToQhasm' a (start + 3)) ++ + [QLabel (N.to_nat finish)] + | AWhile c a => + let start := N.to_nat (N.shiftl 1 label0) in + let test := S start in + [ QCond CTrue test ; + QLabel start ] ++ + (almostToQhasm' a label1) ++ + [ QLabel test; + QCond c start ] + | ADef lbl f x => + let start' := N.shiftl 1 label0 in + let start'' := (1 + start')%N in + + [ QLabel lbl ] ++ + (almostToQhasm' f start') ++ + [ QRet ] ++ + (almostToQhasm' x start'') + + | ACall lbl => [QCall lbl] + end. + + Transparent Qhasm.Program AlmostQhasm.Program. + + Definition convertProgram x y (prog: AlmostQhasm.Program x): + option (Qhasm.Program y) := + Some (almostToQhasm' prog 0%N). + + Definition convertState x y (st: Qhasm.State y): + option (AlmostQhasm.State x) := + Some st. + + Lemma convert_spec: forall pa pb a a' b b' prog prog', + convertProgram pa pb prog = Some prog' -> + convertState pa pb a = Some a' -> + convertState pa pb b = Some b' -> + Qhasm.evaluatesTo pb prog' a b <-> AlmostQhasm.evaluatesTo pa prog a' b'. + Admitted. + +End AlmostConversion. diff --git a/src/Assembly/AlmostQhasm.v b/src/Assembly/AlmostQhasm.v new file mode 100644 index 000000000..f3ed925c7 --- /dev/null +++ b/src/Assembly/AlmostQhasm.v @@ -0,0 +1,77 @@ +Require Import QhasmCommon QhasmEvalCommon. +Require Import Language. +Require Import List. + +Module AlmostQhasm <: Language. + Import QhasmEval. + + (* Program Types *) + Definition Params := unit. + Definition State := fun (_: Params) => State. + + Inductive AlmostProgram: Set := + | ASkip: AlmostProgram + | ASeq: AlmostProgram -> AlmostProgram -> AlmostProgram + | AAssign: Assignment -> AlmostProgram + | AOp: Operation -> AlmostProgram + | ACond: Conditional -> AlmostProgram -> AlmostProgram -> AlmostProgram + | AWhile: Conditional -> AlmostProgram -> AlmostProgram + | ADef: Label -> AlmostProgram -> AlmostProgram -> AlmostProgram + | ACall: Label -> AlmostProgram. + + Hint Constructors AlmostProgram. + + Definition Program := fun (_: Params) => AlmostProgram. + + Fixpoint inline (l: nat) (f prog: AlmostProgram) := + match prog with + | ASeq a b => ASeq (inline l f a) (inline l f b) + | ACond c a b => ACond c (inline l f a) (inline l f b) + | AWhile c a => AWhile c (inline l f a) + | ADef l' f' p' => + if (Nat.eq_dec l l') + then prog + else ADef l' (inline l f f') (inline l f p') + | ACall l' => + if (Nat.eq_dec l l') + then f + else prog + | _ => prog + end. + + Inductive AlmostEval {x: Params}: Program x -> State x -> State x -> Prop := + | AESkip: forall s, AlmostEval ASkip s s + | AESeq: forall p p' s s' s'', + AlmostEval p s s' + -> AlmostEval p' s' s'' + -> AlmostEval (ASeq p p') s s'' + | AEAssign a: forall s s', + evalAssignment a s = Some s' + -> AlmostEval (AAssign a) s s' + | AEOp: forall s s' a, + evalOperation a s = Some s' + -> AlmostEval (AOp a) s s' + | AECondFalse: forall c a b s s', + evalCond c s = Some false + -> AlmostEval b s s' + -> AlmostEval (ACond c a b) s s' + | AECondTrue: forall c a b s s', + evalCond c s = Some true + -> AlmostEval a s s' + -> AlmostEval (ACond c a b) s s' + | AEWhileRun: forall c a s s' s'', + evalCond c s = Some true + -> AlmostEval a s s' + -> AlmostEval (AWhile c a) s' s'' + -> AlmostEval (AWhile c a) s s'' + | AEWhileSkip: forall c a s, + evalCond c s = Some false + -> AlmostEval (AWhile c a) s s + | AEFun: forall l f p s s', + AlmostEval (inline l f p) s s' + -> AlmostEval (ADef l f p) s s'. + + Definition evaluatesTo := @AlmostEval. + + (* world peace *) +End AlmostQhasm. diff --git a/src/Assembly/Conversion.v b/src/Assembly/Conversion.v new file mode 100644 index 000000000..239bd6b71 --- /dev/null +++ b/src/Assembly/Conversion.v @@ -0,0 +1,17 @@ + +Require Export Language. + +Module Type Conversion (A B: Language). + + Parameter convertProgram: forall (x: A.Params) (y: B.Params), + A.Program x -> option (B.Program y). + Parameter convertState: forall (x: A.Params) (y: B.Params), + B.State y -> option (A.State x). + + Axiom convert_spec: forall pa pb a a' b b' prog prog', + convertProgram pa pb prog = Some prog' -> + convertState pa pb a = Some a' -> + convertState pa pb b = Some b' -> + B.evaluatesTo pb prog' a b <-> A.evaluatesTo pa prog a' b'. + +End Conversion. diff --git a/src/Assembly/Language.v b/src/Assembly/Language.v new file mode 100644 index 000000000..460aff5fe --- /dev/null +++ b/src/Assembly/Language.v @@ -0,0 +1,8 @@ + +Module Type Language. + Parameter Params: Type. + Parameter Program: Params -> Type. + Parameter State: Params -> Type. + + Parameter evaluatesTo: forall x: Params, Program x -> State x -> State x -> Prop. +End Language. diff --git a/src/Assembly/Output.ml b/src/Assembly/Output.ml new file mode 100644 index 000000000..d84aee0a2 --- /dev/null +++ b/src/Assembly/Output.ml @@ -0,0 +1,14 @@ + +open Result + +let list_to_string s = + let rec loop s n = + match s with + [] -> String.make n '?' + | car :: cdr -> + let result = loop cdr (n + 1) in + Bytes.set result n car; + result + in loop s 0 ;; + +print_string (list_to_string result) ;; diff --git a/src/Assembly/Pipeline.v b/src/Assembly/Pipeline.v new file mode 100644 index 000000000..8e58e7345 --- /dev/null +++ b/src/Assembly/Pipeline.v @@ -0,0 +1,78 @@ +Require Import Bedrock.Word. +Require Import QhasmCommon QhasmEvalCommon. +Require Import Pseudo Qhasm AlmostQhasm Conversion Language. +Require Import PseudoConversion AlmostConversion StringConversion. +Require Import Wordize Vectorize Pseudize. + +Module Pipeline. + Export AlmostQhasm Qhasm QhasmString. + Export Pseudo. + + Transparent Pseudo.Program AlmostQhasm.Program Qhasm.Program QhasmString.Program. + Transparent Pseudo.Params AlmostQhasm.Params Qhasm.Params QhasmString.Params. + + Definition toAlmost {w s n m} (p: @Pseudo w s n m) : option AlmostProgram := + PseudoConversion.convertProgram (mkParams w s n m) tt p. + + Definition toQhasm {w s n m} (p: @Pseudo w s n m) : option (list QhasmStatement) := + omap (toAlmost p) (AlmostConversion.convertProgram tt tt). + + Definition toString {w s n m} (p: @Pseudo w s n m) : option string := + omap (toQhasm p) (StringConversion.convertProgram tt tt). +End Pipeline. + +Module PipelineExamples. + Import Pipeline ListNotations StateCommon EvalUtil ListState. + + Local Notation "v [[ i ]]" := (nth i v (wzero _)) (at level 40). + Local Notation "$$ v" := (natToWord _ v) (at level 40). + + (* + Definition add_example: @pseudeq 32 W32 1 1 (fun v => + plet a := $$ 1 in + plet b := v[[0]] in + [a ^+ b]). + pseudo_solve. + Defined. + + Definition add_ex_str := + (Pipeline.toString (proj1_sig add_example)). + + Definition and_example: @pseudeq 32 W32 1 1 (fun v => + plet a := $$ 1 in + plet b := v[[0]] in + [a ^& b]). + pseudo_solve. + Defined. + + Definition and_ex_str := + (Pipeline.toString (proj1_sig and_example)). + + Definition mult_example: @pseudeq 32 W32 1 1 (fun v => + plet a := $$ 1 in + plet b := v[[0]] in + + (* NOTE: we want the lets in this format to unify with + pseudo_mult_dual *) + plet c := multHigh a b in + plet d := a ^* b in + + [b ^& d]). + pseudo_solve. + Defined. + + Definition mult_ex_str := + (Pipeline.toString (proj1_sig mult_example)). + + Definition comb_example: @pseudeq 32 W32 1 1 (fun v => + plet a := $$ 7 in + plet b := v[[0]] in + ([b ^& a; a ^+ b])). + pseudo_solve. + Admitted. + + Definition comb_ex_str := + (Pipeline.toString (proj1_sig comb_example)). + *) + +End PipelineExamples. diff --git a/src/Assembly/Pseudize.v b/src/Assembly/Pseudize.v new file mode 100644 index 000000000..c167dd6a1 --- /dev/null +++ b/src/Assembly/Pseudize.v @@ -0,0 +1,309 @@ +Require Export Bedrock.Word Bedrock.Nomega. +Require Import NArith NPeano List Sumbool Compare_dec Omega. +Require Import QhasmCommon QhasmEvalCommon QhasmUtil Pseudo State. +Require Export Wordize Vectorize. + +Import Pseudo ListNotations StateCommon EvalUtil ListState. + +Section Conversion. + + Hint Unfold setList getList getVar setCarry setCarryOpt getCarry + getMem setMem overflows. + + Lemma eval_in_length: forall {w s n m} p x M c x' M' c', + @pseudoEval n m w s p (x, M, c) = Some (x', M', c') + -> Datatypes.length x = n. + Proof. Admitted. + + Lemma eval_out_length: forall {w s n m} x M c x' M' c' p, + @pseudoEval n m w s p (x, M, c) = Some (x', M', c') + -> Datatypes.length x' = m. + Proof. Admitted. + + Lemma pseudo_var: forall {w s n} b k x v m c, + (k < n)%nat + -> nth_error x k = Some v + -> pseudoEval (@PVar w s n b (indexize k)) (x, m, c) = Some ([v], m, c). + Proof. + intros; autounfold; simpl; unfold indexize. + destruct (le_dec n 0); simpl. { + replace k with 0 in * by omega; autounfold; simpl in *. + rewrite H0; simpl; intuition. + } + + replace (k mod n) with k by ( + assert (n <> 0) as NZ by omega; + pose proof (Nat.div_mod k n NZ); + replace (k mod n) with (k - n * (k / n)) by intuition; + rewrite (Nat.div_small k n); intuition). + + autounfold; simpl. + destruct (nth_error x k); simpl; try inversion H0; intuition. + Qed. + + Lemma pseudo_mem: forall {w s} n v m c x name len index, + TripleM.find (w, name mod n, index mod len)%nat m = Some (@wordToN w v) + -> pseudoEval (@PMem w s n len (indexize name) (indexize index)) (x, m, c) = Some ([v], m, c). + Proof. + intros; autounfold; simpl. + unfold indexize; + destruct (le_dec n 0), (le_dec len 0); + try replace n with 0 in * by intuition; + try replace len with 0 in * by intuition; + autounfold; simpl in *; rewrite H; + autounfold; simpl; rewrite NToWord_wordToN; + intuition. + Qed. + + Lemma pseudo_const: forall {w s n} x v m c, + pseudoEval (@PConst w s n v) (x, m, c) = Some ([v], m, c). + Proof. intros; simpl; intuition. Qed. + + Lemma pseudo_plus: + forall {w s n} (p: @Pseudo w s n 2) x out0 out1 m0 m1 c0 c1, + pseudoEval p (x, m0, c0) = Some ([out0; out1], m1, c1) + -> pseudoEval (PBin n IAdd p) (x, m0, c0) = + Some ([out0 ^+ out1], m1, + Some (proj1_sig (bool_of_sumbool + (overflows w (&out0 + &out1)%N)%w))). + Proof. + intros; simpl; rewrite H; simpl. + + pose proof (wordize_plus out0 out1). + destruct (overflows w _); autounfold; simpl; try rewrite H0; + try rewrite <- (@Npow2_ignore w (out0 ^+ out1)); + try rewrite NToWord_wordToN; intuition. + Qed. + + Lemma pseudo_bin: + forall {w s n} (p: @Pseudo w s n 2) x out0 out1 m0 m1 c0 c1 op, + op <> IAdd + -> pseudoEval p (x, m0, c0) = Some ([out0; out1], m1, c1) + -> pseudoEval (PBin n op p) (x, m0, c0) = + Some ([fst (evalIntOp op out0 out1)], m1, c1). + Proof. + intros; simpl; rewrite H0; simpl. + + induction op; + try (contradict H; reflexivity); + unfold evalIntOp; autounfold; simpl; + reflexivity. + Qed. + + Lemma pseudo_and: + forall {w s n} (p: @Pseudo w s n 2) x out0 out1 m0 m1 c0 c1, + pseudoEval p (x, m0, c0) = Some ([out0; out1], m1, c1) + -> pseudoEval (PBin n IAnd p) (x, m0, c0) = + Some ([out0 ^& out1], m1, c1). + Proof. + intros. + replace (out0 ^& out1) with (fst (evalIntOp IAnd out0 out1)). + - apply pseudo_bin; intuition; inversion H0. + - unfold evalIntOp; simpl; intuition. + Qed. + + Lemma pseudo_awc: + forall {w s n} (p: @Pseudo w s n 2) x out0 out1 m0 m1 c0 c, + pseudoEval p (x, m0, c0) = Some ([out0; out1], m1, Some c) + -> pseudoEval (PCarry n AddWithCarry p) (x, m0, c0) = + Some ([addWithCarry out0 out1 c], m1, + Some (proj1_sig (bool_of_sumbool (overflows w + (&out0 + &out1 + (if c then 1 else 0))%N)%w))). + Proof. + intros; simpl; rewrite H; simpl. + + pose proof (wordize_awc out0 out1); unfold evalCarryOp. + destruct (overflows w ((& out0)%w + (& out1)%w + + (if c then 1%N else 0%N))); + autounfold; simpl; try rewrite H0; intuition. + Qed. + + Lemma pseudo_shiftr: + forall {w s n} (p: @Pseudo w s n 1) x out m0 m1 c0 c1 k, + pseudoEval p (x, m0, c0) = Some ([out], m1, c1) + -> pseudoEval (PShift n Shr k p) (x, m0, c0) = + Some ([shiftr out k], m1, c1). + Proof. + intros; simpl; rewrite H; autounfold; simpl. + rewrite wordize_shiftr; rewrite NToWord_wordToN; intuition. + Qed. + + Lemma pseudo_comb: + forall {w s n a b} (p0: @Pseudo w s n a) (p1: @Pseudo w s n b) + input out0 out1 m0 m1 m2 c0 c1 c2, + pseudoEval p0 (input, m0, c0) = Some (out0, m1, c1) + -> pseudoEval p1 (input, m1, c1) = Some (out1, m2, c2) + -> pseudoEval (@PComb w s n _ _ p0 p1) (input, m0, c0) = + Some (out0 ++ out1, m2, c2). + Proof. + intros; autounfold; simpl. + rewrite H; autounfold; simpl. + rewrite H0; autounfold; simpl; intuition. + Qed. + + Lemma pseudo_cons: + forall {w s n b} (p0: @Pseudo w s n 1) (p1: @Pseudo w s n b) + (p2: @Pseudo w s n (S b)) input x xs m0 m1 m2 c0 c1 c2, + pseudoEval p0 (input, m0, c0) = Some ([x], m1, c1) + -> pseudoEval p1 (input, m1, c1) = Some (xs, m2, c2) + -> p2 = (@PComb w s n _ _ p0 p1) + -> pseudoEval p2 (input, m0, c0) = Some (x :: xs, m2, c2). + Proof. + intros. + replace (x :: xs) with ([x] ++ xs) by (simpl; intuition). + rewrite H1. + apply (pseudo_comb p0 p1 input _ _ m0 m1 m2 c0 c1 c2); intuition. + Qed. + + Lemma pseudo_let: + forall {w s n k m} (p0: @Pseudo w s n k) (p1: @Pseudo w s (n + k) m) + input out0 out1 m0 m1 m2 c0 c1 c2, + pseudoEval p0 (input, m0, c0) = Some (out0, m1, c1) + -> pseudoEval p1 (input ++ out0, m1, c1) = Some (out1, m2, c2) + -> pseudoEval (@PLet w s n k m p0 p1) (input, m0, c0) = + Some (out1, m2, c2). + Proof. + intros; autounfold; simpl. + rewrite H; autounfold; simpl. + rewrite H0; autounfold; simpl; intuition. + Qed. + + Lemma pseudo_let_var: + forall {w s n k m} (p0: @Pseudo w s n k) (p1: @Pseudo w s (n + k) m) + input a f m0 m1 m2 c0 c1 c2, + pseudoEval p0 (input, m0, c0) = Some ([a], m1, c1) + -> pseudoEval p1 (input ++ [a], m1, c1) = Some (f (nth n (input ++ [a]) (wzero _)), m2, c2) + -> pseudoEval (@PLet w s n k m p0 p1) (input, m0, c0) = + Some (Let_In a f, m2, c2). + Proof. + intros; unfold Let_In; cbv zeta. + eapply pseudo_let; try eassumption. + replace (f a) with (f (nth n (input ++ [a]) (wzero w))); try assumption. + apply f_equal. + assert (Datatypes.length input = n) as L by ( + eapply eval_in_length; eassumption). + + rewrite app_nth2; try rewrite L; intuition. + replace (n - n) with 0 by omega; simpl; intuition. + Qed. + + Lemma pseudo_let_list: + forall {w s n k m} (p0: @Pseudo w s n k) (p1: @Pseudo w s (n + k) m) + input lst f m0 m1 m2 c0 c1 c2, + pseudoEval p0 (input, m0, c0) = Some (lst, m1, c1) + -> pseudoEval p1 (input ++ lst, m1, c1) = Some (f lst, m2, c2) + -> pseudoEval (@PLet w s n k m p0 p1) (input, m0, c0) = + Some (Let_In lst f, m2, c2). + Proof. + intros; unfold Let_In; cbv zeta. + eapply pseudo_let; try eassumption. + Qed. + + Lemma pseudo_mult_single: + forall {w s n m} (p0: @Pseudo w s n 2) + (p1: @Pseudo w s (n + 2) m) + out0 out1 f x m0 m1 m2 c0 c1 c2, + pseudoEval p0 (x, m0, c0) = Some ([out0; out1], m1, c1) + -> pseudoEval p1 (x ++ [out0 ^* out1; multHigh out0 out1], m1, c1) = + Some (f (nth n (x ++ [out0 ^* out1; multHigh out0 out1]) (wzero _)), m2, c2) + -> pseudoEval (@PLet w s n 2 m (PDual n Mult p0) p1) (x, m0, c0) = + Some (Let_In (out0 ^* out1) f, m2, c2). + Proof. + intros; simpl; rewrite H; autounfold; simpl; rewrite H0; simpl; intuition. + replace (nth n (x ++ _) _) with (out0 ^* out1); simpl; intuition. + assert (Datatypes.length x = n) as L by ( + eapply eval_in_length; eassumption). + rewrite app_nth2; try rewrite L; intuition. + replace (n - n) with 0 by omega. + simpl; intuition. + Qed. + + Lemma pseudo_mult_dual: + forall {w s n m} (p0: @Pseudo w s n 2) + (p1: @Pseudo w s (n + 2) m) + out0 out1 f x m0 m1 m2 c0 c1 c2, + pseudoEval p0 (x, m0, c0) = Some ([out0; out1], m1, c1) + -> pseudoEval p1 (x ++ [out0 ^* out1; multHigh out0 out1], m1, c1) = + Some (f (nth n (x ++ [out0 ^* out1; multHigh out0 out1]) (wzero _)) + (nth (S n) (x ++ [out0 ^* out1; multHigh out0 out1]) (wzero _)), + m2, c2) + -> pseudoEval (@PLet w s n 2 m (PDual n Mult p0) p1) (x, m0, c0) = + Some (Let_In (multHigh out0 out1) (fun x => + Let_In (out0 ^* out1) (fun y => + f y x)), m2, c2). + Proof. + intros; simpl; rewrite H; autounfold; simpl; rewrite H0; simpl; intuition. + assert (Datatypes.length x = n) as L by (eapply eval_in_length; eassumption). + + replace (nth n (x ++ _) _) with (out0 ^* out1); simpl; intuition. + replace (nth (S n) (x ++ _) _) with (multHigh out0 out1); simpl; intuition. + + - rewrite app_nth2; try rewrite L; intuition. + replace (S n - n) with 1 by omega. + simpl; intuition. + + - rewrite app_nth2; try rewrite L; intuition. + replace (n - n) with 0 by omega. + simpl; intuition. + Qed. + + Definition pseudeq {w s} (n m: nat) (f: list (word w) -> list (word w)) : Type := + {p: @Pseudo w s n m | forall x: (list (word w)), + List.length x = n -> exists m' c', + pseudoEval p (x, TripleM.empty N, None) = Some (f x, m', c')}. +End Conversion. + +Ltac autodestruct := + repeat match goal with + | [H: context[Datatypes.length (cons _ _)] |- _] => simpl in H + | [H: context[Datatypes.length nil] |- _] => simpl in H + | [H: S ?a = S ?b |- _] => inversion H; clear H + | [H: (S ?a) = 0 |- _] => contradict H; intuition + | [H: 0 = (S ?a) |- _] => contradict H; intuition + | [H: 0 = 0 |- _] => clear H + | [x: list ?T |- _] => + match goal with + | [H: context[Datatypes.length x] |- _] => destruct x + end + end. + +Ltac pseudo_step := + match goal with + | [ |- pseudoEval ?p _ = Some (( + Let_In (multHigh ?a ?b) (fun x => + Let_In (?a ^* ?b) (fun y => _))), _, _) ] => + is_evar p; eapply pseudo_mult_dual + + | [ |- pseudoEval ?p _ = Some (Let_In (?a ^* ?b) _, _, _) ] => + is_evar p; eapply pseudo_mult_single + + | [ |- pseudoEval ?p _ = Some ([?x ^& ?y], _, _) ] => + is_evar p; eapply pseudo_and + + | [ |- pseudoEval ?p _ = Some ([?x ^+ ?y], _, _) ] => + is_evar p; eapply pseudo_plus + + | [ |- pseudoEval ?p _ = Some (cons ?x (cons _ _), _, _) ] => + is_evar p; eapply pseudo_cons; try reflexivity + + | [ |- pseudoEval ?p _ = Some ([natToWord _ ?x], _, _)%p ] => + is_evar p; eapply pseudo_const + + | [ |- pseudoEval ?p _ = Some ((Let_In ?a ?f), _, _) ] => + is_evar p; + match (type of a) with + | list _ => eapply pseudo_let_list + | word _ => eapply pseudo_let_var + | (_ * _)%type => rewrite detuple_let + end + + | [ |- @pseudoEval ?n _ _ _ ?P _ = + Some ([nth ?i ?lst _], _, _)%p ] => + eapply (pseudo_var None i); simpl; intuition + end. + +Ltac pseudo_solve := + repeat eexists; + autounfold; + autodestruct; + repeat pseudo_step. diff --git a/src/Assembly/Pseudo.v b/src/Assembly/Pseudo.v new file mode 100644 index 000000000..e3f1e63ff --- /dev/null +++ b/src/Assembly/Pseudo.v @@ -0,0 +1,182 @@ +Require Import QhasmCommon QhasmUtil State. +Require Import Language QhasmEvalCommon. +Require Import List Compare_dec Omega. + +Module Pseudo <: Language. + Import EvalUtil ListState. + + Inductive Pseudo {w: nat} {s: Width w}: nat -> nat -> Type := + | PVar: forall n, option bool -> Index n -> Pseudo n 1 + | PMem: forall n m , Index n -> Index m -> Pseudo n 1 + | PConst: forall n, word w -> Pseudo n 1 + | PBin: forall n, IntOp -> Pseudo n 2 -> Pseudo n 1 + | PDual: forall n, DualOp -> Pseudo n 2 -> Pseudo n 2 + | PCarry: forall n, CarryOp -> Pseudo n 2 -> Pseudo n 1 + | PShift: forall n, RotOp -> Index w -> Pseudo n 1 -> Pseudo n 1 + | PFunExp: forall n, Pseudo n n -> nat -> Pseudo n n + | PLet: forall n k m, Pseudo n k -> Pseudo (n + k) m -> Pseudo n m + | PComb: forall n a b, Pseudo n a -> Pseudo n b -> Pseudo n (a + b) + | PCall: forall n m, Label -> Pseudo n m -> Pseudo n m + | PIf: forall n m, TestOp -> Index n -> Index n -> + Pseudo n m -> Pseudo n m -> Pseudo n m. + + Hint Constructors Pseudo. + + Record Params': Type := mkParams { + width: nat; + spec: Width width; + inputs: nat; + outputs: nat + }. + + Definition Params := Params'. + Definition State (p: Params): Type := ListState (width p). + Definition Program (p: Params): Type := + @Pseudo (width p) (spec p) (inputs p) (outputs p). + + Definition Unary32: Params := mkParams 32 W32 1 1. + Definition Unary64: Params := mkParams 64 W64 1 1. + + (* Evaluation *) + + Fixpoint pseudoEval {n m w s} (prog: @Pseudo w s n m) (st: ListState w): option (ListState w) := + match prog with + | PVar n _ i => omap (getVar i st) (fun x => Some (setList [x] st)) + | PMem n m v i => omap (getMem v i st) (fun x => Some (setList [x] st)) + | PConst n c => Some (setList [c] st) + | PBin n o p => + omap (pseudoEval p st) (fun sp => + match (getList sp) with + | [wa; wb] => + let (v, c) := evalIntOp o wa wb in + Some (setList [v] (setCarryOpt c sp)) + | _ => None + end) + + | PCarry n o p => + omap (pseudoEval p st) (fun sp => + match (getList sp, getCarry sp) with + | ([wa; wb], Some c) => + let (v, c') := evalCarryOp o wa wb c in + Some (setList [v] (setCarry c' sp)) + | _ => None + end) + + | PDual n o p => + omap (pseudoEval p st) (fun sp => + match (getList sp) with + | [wa; wb] => + let (low, high) := evalDualOp o wa wb in + Some (setList [low; high] sp) + | _ => None + end) + + | PShift n o a x => + omap (pseudoEval x st) (fun sx => + match (getList sx) with + | [wx] => Some (setList [evalRotOp o wx a] sx) + | _ => None + end) + + | PLet n k m f g => + omap (pseudoEval f st) (fun sf => + omap (pseudoEval g (setList ((getList st) ++ (getList sf)) sf)) + (fun sg => Some sg)) + + | PComb n a b f g => + omap (pseudoEval f st) (fun sf => + omap (pseudoEval g (setList (getList st) sf)) (fun sg => + Some (setList ((getList sf) ++ (getList sg)) sg))) + + | PIf n m t i0 i1 l r => + omap (getVar i0 st) (fun v0 => + omap (getVar i1 st) (fun v1 => + if (evalTest t v0 v1) + then pseudoEval l st + else pseudoEval r st )) + + | PFunExp n p e => + (fix funexpseudo (e': nat) (st': ListState w) := + match e' with + | O => Some st' + | S e'' => + omap (pseudoEval p st') (fun st'' => + funexpseudo e'' st'') + end) e st + + | PCall n m _ p => pseudoEval p st + end. + + Definition evaluatesTo (p: Params) (prog: Program p) (st st': State p) := + pseudoEval prog st = Some st'. + + Delimit Scope pseudo_notations with p. + Local Open Scope pseudo_notations. + + Definition indexize {n: nat} (x: nat): Index n. + intros; destruct (le_dec n 0). + + - exists 0; abstract intuition. + - exists (x mod n)%nat; abstract ( + pose proof (Nat.mod_bound_pos x n); omega). + Defined. + + Notation "% A" := (PVar _ (Some false) (indexize A)) + (at level 20, right associativity) : pseudo_notations. + + Notation "$ A" := (PVar _ (Some true) (indexize A)) + (at level 20, right associativity) : pseudo_notations. + + Notation "A :[ B ]:" := (PMem _ _ (indexize A) (indexize B)) + (at level 20, right associativity) : pseudo_notations. + + Notation "# A" := (PConst _ (natToWord _ A)) + (at level 20, right associativity) : pseudo_notations. + + Notation "A :+: B" := (PBin _ IAdd (PComb _ _ _ A B)) + (at level 60, right associativity) : pseudo_notations. + + Notation "A :+c: B" := (PCarry _ AddWithCarry (PComb _ _ _ A B)) + (at level 60, right associativity) : pseudo_notations. + + Notation "A :-: B" := (PBin _ ISub (PComb _ _ _ A B)) + (at level 60, right associativity) : pseudo_notations. + + Notation "A :&: B" := (PBin _ IAnd (PComb _ _ _ A B)) + (at level 45, right associativity) : pseudo_notations. + + Notation "A :^: B" := (PBin _ IXor (PComb _ _ _ A B)) + (at level 45, right associativity) : pseudo_notations. + + Notation "A :>>: B" := (PShift _ Shr (indexize B) A) + (at level 60, right associativity) : pseudo_notations. + + Notation "A :<<: B" := (PShift _ Shl (indexize B) A) + (at level 60, right associativity) : pseudo_notations. + + Notation "A :*: B" := (PDual _ Mult (PComb _ _ _ A B)) + (at level 55, right associativity) : pseudo_notations. + + Notation "O :( A , B ): :?: L ::: R" := + (PIf _ _ O (indexize A) (indexize B) L R) + (at level 70, right associativity) : pseudo_notations. + + Notation "F :**: e" := + (PFunExp _ F e) + (at level 70, right associativity) : pseudo_notations. + + Notation "E :->: F" := + (PLet _ _ _ E F) + (at level 70, right associativity) : pseudo_notations. + + Notation "A :|: B" := + (PComb _ _ _ A B) + (at level 65, left associativity) : pseudo_notations. + + Notation "n ::: A :():" := + (PCall _ _ n A) + (at level 65, left associativity) : pseudo_notations. + + Close Scope pseudo_notations. +End Pseudo. + diff --git a/src/Assembly/PseudoConversion.v b/src/Assembly/PseudoConversion.v new file mode 100644 index 000000000..9959e5319 --- /dev/null +++ b/src/Assembly/PseudoConversion.v @@ -0,0 +1,258 @@ +Require Export Language Conversion QhasmCommon QhasmEvalCommon QhasmUtil. +Require Export Pseudo AlmostQhasm State. +Require Import Bedrock.Word NArith NPeano Euclid. +Require Import List Sumbool Vector. + +Module PseudoConversion <: Conversion Pseudo AlmostQhasm. + Import AlmostQhasm EvalUtil ListState Pseudo ListNotations. + + Section Conv. + Variable w: nat. + Variable s: Width w. + + Definition MMap := NatM.t (Mapping w). + Definition mempty := NatM.empty (Mapping w). + + Definition FMap := NatM.t (AlmostProgram * (list (Mapping w))). + Definition fempty := NatM.empty (AlmostProgram * (list (Mapping w))). + + Transparent MMap FMap. + + Definition getStart {n m} (prog: @Pseudo w s n m) := + let ns := (fix getStart' {n' m'} (prog': @Pseudo w s n' m') := + match prog' with + | PVar _ _ i => [proj1_sig i] + | PBin _ _ p => getStart' p + | PDual _ _ p => getStart' p + | PCarry _ _ p => getStart' p + | PShift _ _ _ p => getStart' p + | PFunExp _ p _ => getStart' p + | PCall _ _ _ p => getStart' p + | PIf _ _ _ _ _ l r => (getStart' l) ++ (getStart' r) + | PLet _ k _ a b => (n + k) :: (getStart' a) ++ (getStart' b) + | PComb _ _ _ a b => (getStart' a) ++ (getStart' b) + | _ => [] + end) _ _ prog in + + (fix maxN (lst: list nat) := + match lst with + | [] => O + | x :: xs => max x (maxN xs) + end) (n :: m :: ns). + + Definition addMap {T} (a b: (NatM.t T)) : NatM.t T := + (fix add' (m: NatM.t T) (elts: list (nat * T)%type) := + match elts with + | [] => m + | (k, v) :: elts' => add' (NatM.add k v m) elts' + end) a (NatM.elements b). + + Fixpoint convertProgram' {n m} (prog: @Pseudo w s n m) (start: nat) (M: MMap) (F: FMap) : + option (AlmostProgram * (list (Mapping w)) * MMap * FMap) := + + let rM := fun (x: nat) => regM _ (reg s x) in + let sM := fun (x: nat) => stackM _ (stack s x) in + let reg' := reg s in + let stack' := stack s in + let const' := constant s in + + let get := fun (k: nat) (default: nat -> Mapping w) (M': MMap) => + match (NatM.find k M') with + | Some v => v + | _ => default k + end in + + let madd := fun (a: nat) (default: nat -> Mapping w) (M': MMap) => + NatM.add a (get a default M') M' in + + let fadd := fun (k: nat) (f: AlmostProgram) (r: list (Mapping w)) => + NatM.add k (f, r) in + + let updateM := ( + fix updateM' (k: nat) (mtmp: list (Mapping w)) (Miter: MMap) : MMap := + match mtmp with + | [] => Miter + | a :: mtmp' => NatM.add k a (updateM' (S k) mtmp' Miter) + end) in + + match prog with + | PVar n (Some true) i => + Some (ASkip, [get i rM M], madd i rM M, F) + + | PVar n (Some false) i => + Some (ASkip, [get i sM M], madd i sM M, F) + + | PVar n None i => (* assign to register by default *) + Some (ASkip, [get i rM M], madd i rM M, F) + + | PConst n c => + Some (AAssign (AConstInt (reg' start) (const' c)), + [get start rM M], madd start rM M, F) + + | PMem n m v i => + Some (AAssign (ARegMem (reg' start) (mem s v) i), + [get start rM M], madd start rM M, F) + + | PBin n o p => + match (convertProgram' p start M F) with + | Some (p', [regM (reg _ _ a); regM (reg _ _ b)], M', F') => + Some (ASeq p' (AOp (IOpReg o (reg' a) (reg' b))), + [get a rM M'], madd a rM (madd b rM M'), F') + + | Some (p', [regM (reg _ _ a); constM c], M', F') => + Some (ASeq p' (AOp (IOpConst o (reg' a) c)), + [get a rM M'], madd a rM M', F') + + | Some (p', [regM (reg _ _ a); memM _ b i], M', F') => + Some (ASeq p' (AOp (IOpMem o (reg' a) b i)), + [get a rM M'], madd a rM M', F') + + | Some (p', [regM (reg _ _ a); stackM (stack _ _ b)], M', F') => + Some (ASeq p' (AOp (IOpStack o (reg' a) (stack' b))), + [get a rM M'], madd a rM (madd b sM M'), F') + + | _ => None + end + + | PCarry n o p => + match (convertProgram' p start M F) with + | Some (p', [regM (reg _ _ a); regM (reg _ _ b)], M', F') => + Some (ASeq p' (AOp (COp o (reg' a) (reg' b))), + [get a rM M'], madd a rM (madd b rM M'), F') + + | _ => None + end + + | PDual n o p => + match (convertProgram' p (S start) M F) with + | Some (p', [regM (reg _ _ a); regM (reg _ _ b)], M', F') => + Some (ASeq p' (AOp (DOp o (reg' a) (reg' b) (Some (reg' start)))), + [get a rM M'; get start rM M'], + madd a rM (madd b rM (madd start rM M')), F') + + | _ => None + end + + | PShift n o x p => + match (convertProgram' p start M F) with + | Some (p', [regM (reg _ _ a)], M', F') => + Some (ASeq p' (AOp (ROp o (reg' a) x)), + [get a rM M'], madd a rM M', F') + + | _ => None + end + + | PLet n k m f g => + match (convertProgram' f start M F) with + | None => None + | Some (fp, fm, M', F') => + + (* Make sure all of the new variables are bound to their results *) + let M'' := updateM start fm M' in + + (* Then convert the second program *) + match (convertProgram' g (start + (length fm)) M'' F') with + | None => None + | Some (gp, gm, M''', F'') => Some (ASeq fp gp, gm, M''', F'') + end + end + + | PComb n a b f g => + match (convertProgram' f start M F) with + | None => None + | Some (fp, fm, M', F') => + match (convertProgram' g (start + (length fm)) M' F') with + | None => None + | Some (gp, gm, M'', F'') => Some (ASeq fp gp, fm ++ gm, M'', F'') + end + end + + | PIf n m o i0 i1 l r => + match (convertProgram' l start M F) with + | None => None + | Some (lp, lr, lM, lF) => + + match (convertProgram' r start lM lF) with + | None => None + | Some (rp, rr, M', F') => + + if (list_eq_dec mapping_dec lr rr) + then + match (get (proj1_sig i0) rM M, get (proj1_sig i1) rM M) with + | (regM r0, regM r1) => Some (ACond (CReg _ o r0 r1) lp rp, lr, M', F') + | (regM r, constM c) => Some (ACond (CConst _ o r c) lp rp, lr, M', F') + | _ => None + end + else None + end + end + + | PFunExp n f e => + match (convertProgram' f (S start) M F) with + | Some (fp, fr, M', F') => + let a := start in + Some (ASeq + (AAssign (AConstInt (reg' a) (const' (natToWord _ O)))) + (AWhile (CConst _ TLt (reg' a) (const' (natToWord _ e))) + (ASeq fp (AOp (IOpConst IAdd (reg' a) (const' (natToWord _ 1)))))), + fr, madd a rM M', F') + + | _ => None + end + + | PCall n m lbl f => + match (convertProgram' f start M F) with + | Some (fp, fr, M', F') => + let F'' := NatM.add lbl (fp, fr) F' in + Some (ACall lbl, fr, M', F'') + | None => None + end + end. + + End Conv. + + Definition convertProgram x y (prog: Program x) : option (AlmostQhasm.Program y) := + let vs := max (inputs x) (outputs x) in + let M0 := mempty (width x) in + let F0 := fempty (width x) in + + match (convertProgram' (width x) (spec x) prog vs M0 F0) with + | Some (prog', _, M, F) => + Some (fold_left + (fun p0 t => match t with | (k, (v, _)) => ADef k v p0 end) + prog' + (of_list (NatM.elements F))) + | _ => None + end. + + Fixpoint convertState x y (st: AlmostQhasm.State y) : option (State x) := + let vars := max (inputs x) (outputs x) in + + let try_cons := fun {T} (x: option T) (l: list T) => + match x with | Some x' => x' :: l | _ => l end in + + let get := fun i => + match (FullState.getReg (reg (spec x) i) st, + FullState.getStack (stack (spec x) i) st) with + | (Some v, _) => Some v + | (_, Some v) => Some v + | _ => None + end in + + let varList := (fix cs' (n: nat) := + try_cons (get (vars - n)) (match n with | O => [] | S m => cs' m end)) vars in + + match st with + | FullState.fullState _ _ memState _ carry => + if (Nat.eq_dec (length varList) vars) + then Some (varList, memState, carry) + else None + end. + + Lemma convert_spec: forall pa pb a a' b b' prog prog', + convertProgram pa pb prog = Some prog' -> + convertState pa pb a = Some a' -> + convertState pa pb b = Some b' -> + AlmostQhasm.evaluatesTo pb prog' a b <-> evaluatesTo pa prog a' b'. + Admitted. +End PseudoConversion. diff --git a/src/Assembly/Qhasm.v b/src/Assembly/Qhasm.v new file mode 100644 index 000000000..9ba2c0a56 --- /dev/null +++ b/src/Assembly/Qhasm.v @@ -0,0 +1,87 @@ +Require Import QhasmCommon QhasmEvalCommon. +Require Import Language. +Require Import List NPeano. + +Module Qhasm <: Language. + Import ListNotations. + Import QhasmEval. + + (* A constant upper-bound on the number of operations we run *) + Definition Params := unit. + Definition State := fun (_: Params) => State. + + Transparent Params. + + (* Program Types *) + Inductive QhasmStatement := + | QAssign: Assignment -> QhasmStatement + | QOp: Operation -> QhasmStatement + | QCond: Conditional -> Label -> QhasmStatement + | QLabel: Label -> QhasmStatement + | QCall: Label -> QhasmStatement + | QRet: QhasmStatement. + + Hint Constructors QhasmStatement. + + Definition Program := fun (_: Params) => list QhasmStatement. + + (* Only execute while loops a fixed number of times. + TODO (rsloan): can we do any better? *) + + Fixpoint getLabelMap' {x} (prog: Program x) (cur: LabelMap) (index: nat): LabelMap := + match prog with + | p :: ps => + match p with + | QLabel label => @getLabelMap' x ps (NatM.add label index cur) (S index) + | _ => @getLabelMap' x ps cur (S index) + end + | [] => cur + end. + + Definition getLabelMap {x} (prog: Program x): LabelMap := + getLabelMap' prog (NatM.empty nat) O. + + Inductive QhasmEval {x}: nat -> Program x -> LabelMap -> State x -> State x -> Prop := + | QEOver: forall p n m s, (n > (length p))%nat -> QhasmEval n p m s s + | QEZero: forall p s m, QhasmEval O p m s s + | QEAssign: forall n p m a s s' s'', + (nth_error p n) = Some (QAssign a) + -> evalAssignment a s = Some s' + -> QhasmEval (S n) p m s' s'' + -> QhasmEval n p m s s'' + | QEOp: forall n p m a s s' s'', + (nth_error p n) = Some (QOp a) + -> evalOperation a s = Some s' + -> QhasmEval (S n) p m s' s'' + -> QhasmEval n p m s s'' + | QECondTrue: forall (n loc next: nat) p m c l s s', + (nth_error p n) = Some (QCond c l) + -> evalCond c s = Some true + -> NatM.find l m = Some loc + -> QhasmEval loc p m s s' + -> QhasmEval n p m s s' + | QECondFalse: forall (n loc next: nat) p m c l s s', + (nth_error p n) = Some (QCond c l) + -> evalCond c s = Some false + -> QhasmEval (S n) p m s s' + -> QhasmEval n p m s s' + | QERet: forall (n n': nat) s s' s'' p m, + (nth_error p n) = Some QRet + -> popRet s = Some (s', n') + -> QhasmEval n' p m s' s'' + -> QhasmEval n p m s s'' + | QECall: forall (w n n' lbl: nat) s s' s'' p m, + (nth_error p n) = Some (QCall lbl) + -> NatM.find lbl m = Some n' + -> QhasmEval n' p m (pushRet (S n) s') s'' + -> QhasmEval n p m s s'' + | QELabel: forall n p m l s s', + (nth_error p n) = Some (QLabel l) + -> QhasmEval (S n) p m s s' + -> QhasmEval n p m s s'. + + Definition evaluatesTo := fun (x: Params) p => @QhasmEval x O p (getLabelMap p). + + (* world peace *) +End Qhasm. + diff --git a/src/Assembly/QhasmCommon.v b/src/Assembly/QhasmCommon.v new file mode 100644 index 000000000..908d16037 --- /dev/null +++ b/src/Assembly/QhasmCommon.v @@ -0,0 +1,131 @@ +Require Export String List NPeano NArith. +Require Export Bedrock.Word. + +(* Utilities *) +Definition Label := nat. + +Definition Index (limit: nat) := {x: nat | (x <= (pred limit))%nat}. +Coercion indexToNat {lim: nat} (i: Index lim): nat := proj1_sig i. + +Inductive Either A B := + | xleft: A -> Either A B + | xright: B -> Either A B. + +Definition convert {A B: Type} (x: A) (H: A = B): B := + eq_rect A (fun B0 : Type => B0) x B H. + +(* Asm Types *) +Inductive Width: nat -> Type := | W32: Width 32 | W64: Width 64. + +(* A constant value *) +Inductive Const: nat -> Type := + | constant: forall {n}, Width n -> word n -> Const n. + +(* A variable in any register *) +Inductive Reg: nat -> Type := + | reg: forall {n}, Width n -> nat -> Reg n. + +(* A variable on the stack. We should use this sparingly. *) +Inductive Stack: nat -> Type := + | stack: forall {n}, Width n -> nat -> Stack n. + +(* A pointer to a memory block. Called as: + mem width index length + where length is in words of size width. + + All Mem pointers will be declared as Stack arguments in the + resulting qhasm output *) +Inductive Mem: nat -> nat -> Type := + | mem: forall {n m}, Width n -> nat -> Mem n m. + +(* The state of the carry flag: + 1 = Some true + 0 = Some false + unknown = None *) +Definition Carry := option bool. + +(* Assignments *) + +Inductive Assignment : Type := + | ARegMem: forall {n m}, Reg n -> Mem n m -> Index m -> Assignment + | AMemReg: forall {n m}, Mem n m -> Index m -> Reg n -> Assignment + | AStackReg: forall {n}, Stack n -> Reg n -> Assignment + | ARegStack: forall {n}, Reg n -> Stack n -> Assignment + | ARegReg: forall {n}, Reg n -> Reg n -> Assignment + | AConstInt: forall {n}, Reg n -> Const n -> Assignment. + +(* Operations *) + +Inductive IntOp := + | IAdd: IntOp + | ISub: IntOp + | IXor: IntOp + | IAnd: IntOp + | IOr: IntOp. + +Inductive CarryOp := | AddWithCarry: CarryOp. + +Inductive DualOp := | Mult: DualOp. + +Inductive RotOp := | Shl: RotOp | Shr: RotOp. + +Inductive Operation := + | IOpConst: forall {n}, IntOp -> Reg n -> Const n -> Operation + | IOpReg: forall {n}, IntOp -> Reg n -> Reg n -> Operation + | IOpMem: forall {n m}, IntOp -> Reg n -> Mem n m -> Index m -> Operation + | IOpStack: forall {n}, IntOp -> Reg n -> Stack n -> Operation + | DOp: forall {n}, DualOp -> Reg n -> Reg n -> option (Reg n) -> Operation + | ROp: forall {n}, RotOp -> Reg n -> Index n -> Operation + | COp: forall {n}, CarryOp -> Reg n -> Reg n -> Operation. + +(* Control Flow *) + +Inductive TestOp := + | TEq: TestOp | TLt: TestOp | TLe: TestOp + | TGt: TestOp | TGe: TestOp. + +Inductive Conditional := + | CTrue: Conditional + | CZero: forall n, Reg n -> Conditional + | CReg: forall n, TestOp -> Reg n -> Reg n -> Conditional + | CConst: forall n, TestOp -> Reg n -> Const n -> Conditional. + +(* Generalized Variable Entry *) + +Inductive Mapping (n: nat) := + | regM: forall (r: Reg n), Mapping n + | stackM: forall (s: Stack n), Mapping n + | memM: forall {m} (x: Mem n m) (i: Index m), Mapping n + | constM: forall (x: Const n), Mapping n. + +(* Parameter Accessors *) + +Definition constWidth {n} (x: Const n): nat := n. + +Definition regWidth {n} (x: Reg n): nat := n. + +Definition stackWidth {n} (x: Stack n): nat := n. + +Definition memWidth {n m} (x: Mem n m): nat := n. + +Definition memLength {n m} (x: Mem n m): nat := m. + +Definition constValueW {n} (x: Const n): word n := + match x with | @constant n _ v => v end. + +Definition constValueN {n} (x: Const n): nat := + match x with | @constant n _ v => wordToNat v end. + +Definition regName {n} (x: Reg n): nat := + match x with | @reg n _ v => v end. + +Definition stackName {n} (x: Stack n): nat := + match x with | @stack n _ v => v end. + +Definition memName {n m} (x: Mem n m): nat := + match x with | @mem n m _ v => v end. + +(* Hints *) +Hint Constructors + Reg Stack Const Mem Mapping + Assignment Operation Conditional. diff --git a/src/Assembly/QhasmEvalCommon.v b/src/Assembly/QhasmEvalCommon.v new file mode 100644 index 000000000..4c64d8681 --- /dev/null +++ b/src/Assembly/QhasmEvalCommon.v @@ -0,0 +1,298 @@ +Require Import QhasmCommon QhasmUtil State. +Require Import ZArith Sumbool. +Require Import Bedrock.Word. +Require Import Logic.Eqdep_dec ProofIrrelevance. + +Module EvalUtil. + Definition evalTest {n} (o: TestOp) (a b: word n): bool := + let c := (N.compare (wordToN a) (wordToN b)) in + + let eqBit := match c with | Eq => true | _ => false end in + let ltBit := match c with | Lt => true | _ => false end in + let gtBit := match c with | Gt => true | _ => false end in + + match o with + | TEq => eqBit + | TLt => ltBit + | TLe => orb (eqBit) (ltBit) + | TGt => gtBit + | TGe => orb (eqBit) (gtBit) + end. + + Definition evalIntOp {b} (io: IntOp) (x y: word b) := + match io return (word b) * option bool with + | ISub => (wminus x y, None) + | IXor => (wxor x y, None) + | IAnd => (wand x y, None) + | IOr => (wor x y, None) + | IAdd => + let v := (wordToN x + wordToN y)%N in + let c := (overflows b (&x + &y)%N)%w in + + match c as c' return c' = c -> _ with + | right _ => fun _ => (NToWord b v, Some false) + | left _ => fun _ => (NToWord b v, Some true) + end eq_refl + end. + + Definition evalCarryOp {b} (io: CarryOp) (x y: word b) (c: bool): (word b) * bool := + match io with + | AddWidthCarry => + let c' := (overflows b (&x + &y + (if c then 1 else 0))%N)%w in + let v := addWithCarry x y c in + + match c' as c'' return c' = c'' -> _ with + | right _ => fun _ => (v, false) + | left _ => fun _ => (v, true) + end eq_refl + end. + + Definition highBits {n} (m: nat) (x: word n) := snd (break m x). + + Definition multHigh {n} (x y: word n): word n. + refine (@extend _ n _ ((highBits (n/2) x) ^* (highBits (n/2) y))); + abstract omega. + Defined. + + Definition evalDualOp {n} (duo: DualOp) (x y: word n) := + match duo with + | Mult => (x ^* y, multHigh x y) + end. + + Definition evalRotOp {b} (ro: RotOp) (x: word b) (n: nat) := + match ro with + | Shl => NToWord b (N.shiftl_nat (wordToN x) n) + | Shr => NToWord b (N.shiftr_nat (wordToN x) n) + end. + + (* Width decideability *) + + Definition getWidth (n: nat): option (Width n) := + match n with + | 32 => Some W32 + | 64 => Some W64 + | _ => None + end. + + Lemma getWidth_eq {n} (a: Width n): Some a = getWidth n. + Proof. induction a; unfold getWidth; simpl; intuition. Qed. + + Lemma width_eq {n} (a b: Width n): a = b. + Proof. + assert (Some a = Some b) as H by ( + replace (Some a) with (getWidth n) by (rewrite getWidth_eq; intuition); + replace (Some b) with (getWidth n) by (rewrite getWidth_eq; intuition); + intuition). + inversion H; intuition. + Qed. + + (* Mapping Conversions *) + + Definition wordToM {n: nat} {spec: Width n} (w: word n): Mapping n := + constM _ (constant spec w). + + Definition regToM {n: nat} {spec: Width n} (r: Reg n): Mapping n := + regM _ r. + + Definition stackToM {n: nat} {spec: Width n} (s: Stack n): Mapping n := + stackM _ s. + + Definition constToM {n: nat} {spec: Width n} (c: Const n): Mapping n := + constM _ c. + + Definition mapping_dec {n} (a b: Mapping n): {a = b} + {a <> b}. + refine (match (a, b) as p' return (a, b) = p' -> _ with + | (regM v, regM v') => fun _ => + if (Nat.eq_dec (regName v) (regName v')) + then left _ + else right _ + + | (stackM v, stackM v') => fun _ => + if (Nat.eq_dec (stackName v) (stackName v')) + then left _ + else right _ + + | (constM v, constM v') => fun _ => + if (Nat.eq_dec (constValueN v) (constValueN v')) + then left _ + else right _ + + | (memM _ v i, memM _ v' i') => fun _ => + if (Nat.eq_dec (memName v) (memName v')) + then if (Nat.eq_dec (memLength v) (memLength v')) + then if (Nat.eq_dec (proj1_sig i) (proj1_sig i')) + then left _ else right _ else right _ else right _ + + | _ => fun _ => right _ + end (eq_refl (a, b))); + try destruct v, v'; subst; + unfold regName, stackName, constValueN, memName, memLength in *; + repeat progress (try apply f_equal; subst; match goal with + (* Makeshift intuition *) + | [ |- ?x = ?x ] => reflexivity + | [ H: ?x <> ?x |- _ ] => destruct H + | [ |- ?x = ?y ] => apply proof_irrelevance + + (* Destruct the widths *) + | [ w0: Width ?x, w1: Width ?x |- _ ] => + let H := fresh in + assert (w0 = w1) as H by (apply width_eq); + rewrite H in *; + clear w0 H + + (* Invert <> *) + | [ |- regM _ _ <> _ ] => let H := fresh in (intro H; inversion H) + | [ |- memM _ _ _ <> _ ] => let H := fresh in (intro H; inversion H) + | [ |- stackM _ _ <> _ ] => let H := fresh in (intro H; inversion H) + | [ |- constM _ _ <> _ ] => let H := fresh in (intro H; inversion H) + + (* Invert common structures *) + | [ H: regName _ = regName _ |- _ ] => inversion_clear H + | [ H: (_, _) = _ |- _ ] => inversion_clear H + | [ H: ?x = _ |- _ ] => is_var x; rewrite H in *; clear H + + (* Destruct sigmas, exist, existT *) + | [ H: proj1_sig ?a = proj1_sig ?b |- _ ] => + let l0 := fresh in let l1 := fresh in + destruct a, b; simpl in H; subst + | [ H: proj1_sig ?a <> proj1_sig ?b |- _ ] => + let l0 := fresh in let l1 := fresh in + destruct a, b; simpl in H; subst + | [ H: existT ?a ?b _ = existT ?a ?b _ |- _ ] => + apply (inj_pair2_eq_dec _ Nat.eq_dec) in H; + subst; intuition + | [ H: exist _ _ _ = exist _ _ _ |- _ ] => + inversion H; subst; intuition + + (* Single specialized wordToNat proof *) + | [ H: wordToNat ?a = wordToNat ?b |- ?a = ?b] => + rewrite <- (natToWord_wordToNat a); + rewrite <- (natToWord_wordToNat b); + rewrite H; reflexivity + + | _ => idtac + end). + Defined. + + Definition dec_lt (a b: nat): {(a < b)%nat} + {(a >= b)%nat}. + assert ({(a <? b)%nat = true} + {(a <? b)%nat <> true}) + by abstract (destruct (a <? b)%nat; intuition); + destruct H. + + - left; abstract (apply Nat.ltb_lt; intuition). + + - right; abstract (rewrite Nat.ltb_lt in *; intuition). + Defined. + + Fixpoint stackNames {n} (lst: list (Mapping n)): list nat := + match lst with + | nil => nil + | cons c cs => + match c with + | stackM v => cons (stackName v) (stackNames cs) + | _ => stackNames cs + end + end. + + Fixpoint regNames {n} (lst: list (Mapping n)): list nat := + match lst with + | nil => nil + | cons c cs => + match c with + | regM v => cons (regName v) (regNames cs) + | _ => regNames cs + end + end. + +End EvalUtil. + +Module QhasmEval. + Export EvalUtil FullState. + + Definition evalCond (c: Conditional) (state: State): option bool := + match c with + | CTrue => Some true + | CZero n r => + omap (getReg r state) (fun v => + if (Nat.eq_dec O (wordToNat v)) + then Some true + else Some false) + | CReg n o a b => + omap (getReg a state) (fun va => + omap (getReg b state) (fun vb => + Some (evalTest o va vb))) + | CConst n o a c => + omap (getReg a state) (fun va => + Some (evalTest o va (constValueW c))) + end. + + Definition evalOperation (o: Operation) (state: State): option State := + match o with + | IOpConst _ o r c => + omap (getReg r state) (fun v => + let (v', co) := (evalIntOp o v (constValueW c)) in + Some (setCarryOpt co (setReg r v' state))) + + | IOpReg _ o a b => + omap (getReg a state) (fun va => + omap (getReg b state) (fun vb => + let (v', co) := (evalIntOp o va vb) in + Some (setCarryOpt co (setReg a v' state)))) + + | IOpStack _ o a b => + omap (getReg a state) (fun va => + omap (getStack b state) (fun vb => + let (v', co) := (evalIntOp o va vb) in + Some (setCarryOpt co (setReg a v' state)))) + + | IOpMem _ _ o r m i => + omap (getReg r state) (fun va => + omap (getMem m i state) (fun vb => + let (v', co) := (evalIntOp o va vb) in + Some (setCarryOpt co (setReg r v' state)))) + + | DOp _ o a b (Some x) => + omap (getReg a state) (fun va => + omap (getReg b state) (fun vb => + let (low, high) := (evalDualOp o va vb) in + Some (setReg x high (setReg a low state)))) + + | DOp _ o a b None => + omap (getReg a state) (fun va => + omap (getReg b state) (fun vb => + let (low, high) := (evalDualOp o va vb) in + Some (setReg a low state))) + + | ROp _ o r i => + omap (getReg r state) (fun v => + let v' := (evalRotOp o v i) in + Some (setReg r v' state)) + + | COp _ o a b => + omap (getReg a state) (fun va => + omap (getReg b state) (fun vb => + match (getCarry state) with + | None => None + | Some c0 => + let (v', c') := (evalCarryOp o va vb c0) in + Some (setCarry c' (setReg a v' state)) + end)) + end. + + Definition evalAssignment (a: Assignment) (state: State): option State := + match a with + | ARegMem _ _ r m i => + omap (getMem m i state) (fun v => Some (setReg r v state)) + | AMemReg _ _ m i r => + omap (getReg r state) (fun v => Some (setMem m i v state)) + | AStackReg _ a b => + omap (getReg b state) (fun v => Some (setStack a v state)) + | ARegStack _ a b => + omap (getStack b state) (fun v => Some (setReg a v state)) + | ARegReg _ a b => + omap (getReg b state) (fun v => Some (setReg a v state)) + | AConstInt _ r c => + Some (setReg r (constValueW c) state) + end. + +End QhasmEval. diff --git a/src/Assembly/QhasmUtil.v b/src/Assembly/QhasmUtil.v new file mode 100644 index 000000000..acf2b5c31 --- /dev/null +++ b/src/Assembly/QhasmUtil.v @@ -0,0 +1,78 @@ +Require Import ZArith NArith NPeano. +Require Import QhasmCommon. +Require Export Bedrock.Word. + +Delimit Scope nword_scope with w. +Local Open Scope nword_scope. + +Notation "& x" := (wordToN x) (at level 30) : nword_scope. +Notation "** x" := (NToWord _ x) (at level 30) : nword_scope. + +Section Util. + Definition convS {A B: Set} (x: A) (H: A = B): B := + eq_rect A (fun B0 : Set => B0) x B H. + + Definition high {k n: nat} (p: (k <= n)%nat) (w: word n): word k. + refine (split1 k (n - k) (convS w _)). + abstract (replace n with (k + (n - k)) by omega; intuition). + Defined. + + Definition low {k n: nat} (p: (k <= n)%nat) (w: word n): word k. + refine (split2 (n - k) k (convS w _)). + abstract (replace n with (k + (n - k)) by omega; intuition). + Defined. + + Definition extend {k n: nat} (p: (k <= n)%nat) (w: word k): word n. + refine (convS (zext w (n - k)) _). + abstract (replace (k + (n - k)) with n by omega; intuition). + Defined. + + Definition shiftr {n} (w: word n) (k: nat): word n := + match (le_dec k n) with + | left p => extend p (high p w) + | right _ => wzero n + end. + + Definition mask {n} (k: nat) (w: word n): word n := + match (le_dec k n) with + | left p => extend p (low p w) + | right _ => w + end. + + Definition overflows (n: nat) (x: N) : + {(x >= Npow2 n)%N} + {(x < Npow2 n)%N}. + refine ( + let c := (x ?= Npow2 n)%N in + match c as c' return c = c' -> _ with + | Lt => fun _ => right _ + | _ => fun _ => left _ + end eq_refl); abstract ( + unfold c in *; unfold N.lt, N.ge; + repeat match goal with + | [ H: (_ ?= _)%N = _ |- _] => + rewrite H; intuition; try inversion H + | [ H: Eq = _ |- _] => inversion H + | [ H: Gt = _ |- _] => inversion H + | [ H: Lt = _ |- _] => inversion H + end). + Defined. + + Definition break {n} (m: nat) (x: word n): word m * word (n - m). + refine match (le_dec m n) with + | left p => (extend _ (low p x), extend _ (@high (n - m) n _ x)) + | right p => (extend _ x, _) + end; try abstract intuition. + + replace (n - m) with O by abstract omega; exact WO. + Defined. + + Definition addWithCarry {n} (x y: word n) (c: bool): word n := + x ^+ y ^+ (natToWord _ (if c then 1 else 0)). + + Definition omap {A B} (x: option A) (f: A -> option B) := + match x with | Some y => f y | _ => None end. + + Notation "A <- X ; B" := (omap X (fun A => B)) (at level 70, right associativity). +End Util. + +Close Scope nword_scope.
\ No newline at end of file diff --git a/src/Assembly/State.v b/src/Assembly/State.v new file mode 100644 index 000000000..8602c7f96 --- /dev/null +++ b/src/Assembly/State.v @@ -0,0 +1,329 @@ +Require Export String List Logic. +Require Export Bedrock.Word. + +Require Import ZArith NArith NPeano Ndec. +Require Import Compare_dec Omega. +Require Import OrderedType Coq.Structures.OrderedTypeEx. +Require Import FMapPositive FMapFullAVL JMeq. + +Require Import QhasmUtil QhasmCommon. + +(* We want to use pairs and triples as map keys: *) + +Module Pair_as_OT <: UsualOrderedType. + Definition t := (nat * nat)%type. + + Definition eq := @eq t. + Definition eq_refl := @eq_refl t. + Definition eq_sym := @eq_sym t. + Definition eq_trans := @eq_trans t. + + Definition lt (a b: t) := + if (Nat.eq_dec (fst a) (fst b)) + then lt (snd a) (snd b) + else lt (fst a) (fst b). + + Lemma conv: forall {x0 x1 y0 y1: nat}, + (x0 = y0 /\ x1 = y1) <-> (x0, x1) = (y0, y1). + Proof. + intros; split; intros. + - destruct H; destruct H0; subst; intuition. + - inversion_clear H; intuition. + Qed. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + intros; destruct x as [x0 x1], y as [y0 y1], z as [z0 z1]; + unfold lt in *; simpl in *; + destruct (Nat.eq_dec x0 y0), (Nat.eq_dec y0 z0), (Nat.eq_dec x0 z0); + omega. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + intros; destruct x as [x0 x1], y as [y0 y1]; + unfold lt, eq in *; simpl in *; + destruct (Nat.eq_dec x0 y0); subst; intuition; + inversion H0; subst; omega. + Qed. + + Definition compare x y : Compare lt eq x y. + destruct x as [x0 x1], y as [y0 y1]; + destruct (Nat_as_OT.compare x0 y0); + unfold Nat_as_OT.lt, Nat_as_OT.eq in *. + + - apply LT; abstract (unfold lt; simpl; destruct (Nat.eq_dec x0 y0); intuition). + + - destruct (Nat_as_OT.compare x1 y1); + unfold Nat_as_OT.lt, Nat_as_OT.eq in *. + + + apply LT; abstract (unfold lt; simpl; destruct (Nat.eq_dec x0 y0); intuition). + + apply EQ; abstract (unfold lt; simpl; subst; intuition). + + apply GT; abstract (unfold lt; simpl; destruct (Nat.eq_dec y0 x0); intuition). + + - apply GT; abstract (unfold lt; simpl; destruct (Nat.eq_dec y0 x0); intuition). + Defined. + + Definition eq_dec (a b: t): {a = b} + {a <> b}. + destruct (compare a b); + destruct a as [a0 a1], b as [b0 b1]. + + - right; abstract ( + unfold lt in *; simpl in *; + destruct (Nat.eq_dec a0 b0); intuition; + inversion H; intuition). + + - left; abstract (inversion e; intuition). + + - right; abstract ( + unfold lt in *; simpl in *; + destruct (Nat.eq_dec b0 a0); intuition; + inversion H; intuition). + Defined. +End Pair_as_OT. + +Module Triple_as_OT <: UsualOrderedType. + Definition t := (nat * nat * nat)%type. + + Definition get0 (x: t) := fst (fst x). + Definition get1 (x: t) := snd (fst x). + Definition get2 (x: t) := snd x. + + Definition eq := @eq t. + Definition eq_refl := @eq_refl t. + Definition eq_sym := @eq_sym t. + Definition eq_trans := @eq_trans t. + + Definition lt (a b: t) := + if (Nat.eq_dec (get0 a) (get0 b)) + then + if (Nat.eq_dec (get1 a) (get1 b)) + then lt (get2 a) (get2 b) + else lt (get1 a) (get1 b) + else lt (get0 a) (get0 b). + + Lemma conv: forall {x0 x1 x2 y0 y1 y2: nat}, + (x0 = y0 /\ x1 = y1 /\ x2 = y2) <-> (x0, x1, x2) = (y0, y1, y2). + Proof. + intros; split; intros. + - destruct H; destruct H0; subst; intuition. + - inversion_clear H; intuition. + Qed. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + intros; unfold lt in *; + destruct (Nat.eq_dec (get0 x) (get0 y)), + (Nat.eq_dec (get1 x) (get1 y)), + (Nat.eq_dec (get0 y) (get0 z)), + (Nat.eq_dec (get1 y) (get1 z)), + (Nat.eq_dec (get0 x) (get0 z)), + (Nat.eq_dec (get1 x) (get1 z)); + omega. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + intros; unfold lt, eq in *; + destruct (Nat.eq_dec (get0 x) (get0 y)), + (Nat.eq_dec (get1 x) (get1 y)); + subst; intuition; + inversion H0; subst; omega. + Qed. + + Ltac compare_tmp x y := + abstract ( + unfold Nat_as_OT.lt, Nat_as_OT.eq, lt, eq in *; + destruct (Nat.eq_dec (get0 x) (get0 y)); + destruct (Nat.eq_dec (get1 x) (get1 y)); + simpl; intuition). + + Ltac compare_eq x y := + abstract ( + unfold Nat_as_OT.lt, Nat_as_OT.eq, lt, eq, get0, get1 in *; + destruct x as [x x2], y as [y y2]; + destruct x as [x0 x1], y as [y0 y1]; + simpl in *; subst; intuition). + + Definition compare x y : Compare lt eq x y. + destruct (Nat_as_OT.compare (get0 x) (get0 y)). + + - apply LT; compare_tmp x y. + - destruct (Nat_as_OT.compare (get1 x) (get1 y)). + + apply LT; compare_tmp x y. + + destruct (Nat_as_OT.compare (get2 x) (get2 y)). + * apply LT; compare_tmp x y. + * apply EQ; compare_eq x y. + * apply GT; compare_tmp y x. + + apply GT; compare_tmp y x. + - apply GT; compare_tmp y x. + Defined. + + Definition eq_dec (a b: t): {a = b} + {a <> b}. + destruct (compare a b); + destruct a as [a a2], b as [b b2]; + destruct a as [a0 a1], b as [b0 b1]. + + - right; abstract ( + unfold lt, get0, get1, get2 in *; simpl in *; + destruct (Nat.eq_dec a0 b0), (Nat.eq_dec a1 b1); + intuition; inversion H; intuition). + + - left; abstract (inversion e; intuition). + + - right; abstract ( + unfold lt, get0, get1, get2 in *; simpl in *; + destruct (Nat.eq_dec b0 a0), (Nat.eq_dec b1 a1); + intuition; inversion H; intuition). + Defined. +End Triple_as_OT. + +Module StateCommon. + Export ListNotations. + + Module NatM := FMapFullAVL.Make(Nat_as_OT). + Module PairM := FMapFullAVL.Make(Pair_as_OT). + Module TripleM := FMapFullAVL.Make(Triple_as_OT). + + Definition NatNMap: Type := NatM.t N. + Definition PairNMap: Type := PairM.t N. + Definition TripleNMap: Type := TripleM.t N. + Definition LabelMap: Type := NatM.t nat. +End StateCommon. + +Module ListState. + Export StateCommon. + + Definition ListState (n: nat) := ((list (word n)) * TripleNMap * (option bool))%type. + + Definition emptyState {n}: ListState n := ([], TripleM.empty N, None). + + Definition getVar {n: nat} (name: nat) (st: ListState n): option (word n) := + nth_error (fst (fst st)) name. + + Definition getList {n: nat} (st: ListState n): list (word n) := + fst (fst st). + + Definition setList {n: nat} (lst: list (word n)) (st: ListState n): ListState n := + (lst, snd (fst st), snd st). + + Definition getMem {n: nat} (name index: nat) (st: ListState n): option (word n) := + omap (TripleM.find (n, name, index) (snd (fst st))) (fun v => Some (NToWord n v)). + + Definition setMem {n: nat} (name index: nat) (v: word n) (st: ListState n): ListState n := + (fst (fst st), TripleM.add (n, name, index) (wordToN v) (snd (fst st)), snd st). + + Definition getCarry {n: nat} (st: ListState n): option bool := (snd st). + + Definition setCarry {n: nat} (v: bool) (st: ListState n): ListState n := + (fst st, Some v). + + Definition setCarryOpt {n: nat} (v: option bool) (st: ListState n): ListState n := + match v with + | Some v' => (fst st, v) + | None => st + end. + +End ListState. + +Module FullState. + Export StateCommon. + + (* The Big Definition *) + + Inductive State := + | fullState (regState: PairNMap) + (stackState: PairNMap) + (memState: TripleNMap) + (retState: list nat) + (carry: Carry): State. + + Definition emptyState: State := + fullState (PairM.empty N) (PairM.empty N) (TripleM.empty N) [] None. + + (* Register *) + + Definition getReg {n} (r: Reg n) (state: State): option (word n) := + match state with + | fullState regS _ _ _ _ => + match (PairM.find (n, regName r) regS) with + | Some v => Some (NToWord n v) + | None => None + end + end. + + Definition setReg {n} (r: Reg n) (value: word n) (state: State): State := + match state with + | fullState regS stackS memS retS carry => + fullState (PairM.add (n, regName r) (wordToN value) regS) + stackS memS retS carry + end. + + (* Stack *) + + Definition getStack {n} (s: Stack n) (state: State): option (word n) := + match state with + | fullState _ stackS _ _ _ => + match (PairM.find (n, stackName s) stackS) with + | Some v => Some (NToWord n v) + | None => None + end + end. + + Definition setStack {n} (s: Stack n) (value: word n) (state: State): State := + match state with + | fullState regS stackS memS retS carry => + fullState regS + (PairM.add (n, stackName s) (wordToN value) stackS) + memS retS carry + end. + + (* Memory *) + + Definition getMem {n m} (x: Mem n m) (i: Index m) (state: State): option (word n) := + match state with + | fullState _ _ memS _ _ => + match (TripleM.find (n, memName x, proj1_sig i) memS) with + | Some v => Some (NToWord n v) + | None => None + end + end. + + Definition setMem {n m} (x: Mem n m) (i: Index m) (value: word n) (state: State): State := + match state with + | fullState regS stackS memS retS carry => + fullState regS stackS + (TripleM.add (n, memName x, proj1_sig i) (wordToN value) memS) + retS carry + end. + + (* Return Pointers *) + + Definition pushRet (x: nat) (state: State): State := + match state with + | fullState regS stackS memS retS carry => + fullState regS stackS memS (cons x retS) carry + end. + + Definition popRet (state: State): option (State * nat) := + match state with + | fullState regS stackS memS [] carry => None + | fullState regS stackS memS (r :: rs) carry => + Some (fullState regS stackS memS rs carry, r) + end. + + (* Carry State Manipulations *) + + Definition getCarry (state: State): Carry := + match state with + | fullState _ _ _ _ b => b + end. + + Definition setCarry (value: bool) (state: State): State := + match state with + | fullState regS stackS memS retS carry => + fullState regS stackS memS retS (Some value) + end. + + Definition setCarryOpt (value: option bool) (state: State): State := + match value with + | Some c' => setCarry c' state + | _ => state + end. +End FullState. diff --git a/src/Assembly/StringConversion.v b/src/Assembly/StringConversion.v new file mode 100644 index 000000000..9f3908a26 --- /dev/null +++ b/src/Assembly/StringConversion.v @@ -0,0 +1,392 @@ +Require Export Language Conversion. +Require Export String Ascii Basics Sumbool. +Require Import QhasmCommon QhasmEvalCommon QhasmUtil Qhasm. +Require Import NArith NPeano. +Require Export Bedrock.Word. + +Module QhasmString <: Language. + Definition Params := unit. + Definition Program := fun (_: Params) => string. + Definition State := fun (_: Params) => unit. + + Definition evaluatesTo x (p: Program x) (i o: State x): Prop := True. +End QhasmString. + +Module StringConversion <: Conversion Qhasm QhasmString. + Import Qhasm ListNotations. + + (* The easy one *) + Definition convertState x y (st: QhasmString.State y): option (Qhasm.State x) := None. + + (* Hexadecimal Primitives *) + + Section Hex. + Local Open Scope string_scope. + + Definition natToDigit (n : nat) : string := + match n with + | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" + | 4 => "4" | 5 => "5" | 6 => "6" | 7 => "7" + | 8 => "8" | 9 => "9" | 10 => "A" | 11 => "B" + | 12 => "C" | 13 => "D" | 14 => "E" | _ => "F" + end. + + Fixpoint nToHex' (n: N) (digitsLeft: nat): string := + match digitsLeft with + | O => "" + | S nextLeft => + match n with + | N0 => "0" + | _ => (nToHex' (N.shiftr_nat n 4) nextLeft) ++ + (natToDigit (N.to_nat (N.land n 15%N))) + end + end. + + Definition nToHex (n: N): string := + let size := (N.size n) in + let div4 := fun x => (N.shiftr x 2%N) in + let size' := (size + 4 - (N.land size 3))%N in + nToHex' n (N.to_nat (div4 size')). + + End Hex. + + (* Conversion of elements *) + + Section Elements. + Local Open Scope string_scope. + + Definition nameSuffix (n: nat): string := + (nToHex (N.of_nat n)). + + Coercion wordToString {n} (w: word n): string := + "0x" ++ (nToHex (wordToN w)). + + Coercion constToString {n} (c: Const n): string := + match c with | constant _ _ w => wordToString w end. + + Coercion regToString {n} (r: Reg n): string := + match r with + | reg _ W32 n => "w" ++ (nameSuffix n) + | reg _ W64 n => "d" ++ (nameSuffix n) + end. + + Coercion natToString (n: nat): string := + "0x" ++ (nToHex (N.of_nat n)). + + Coercion stackToString {n} (s: Stack n): string := + match s with + | stack _ W32 n => "ws" ++ (nameSuffix n) + | stack _ W64 n => "ds" ++ (nameSuffix n) + end. + + Coercion memToString {n m} (s: Mem n m): string := + match s with + | mem _ _ W32 v => "wm" ++ (nameSuffix v) + | mem _ _ W64 v => "dm" ++ (nameSuffix v) + end. + + Coercion stringToSome (x: string): option string := Some x. + + Definition stackLocation {n} (s: Stack n): word 32 := + combine (natToWord 8 n) (natToWord 24 n). + + Definition assignmentToString (a: Assignment): option string := + let f := fun x => if (Nat.eq_dec x 32) then "32" else "64" in + match a with + | ARegStack n r s => r ++ " = *(int" ++ f n ++ " *)" ++ s + | AStackReg n s r => "*(int" ++ f n ++ " *) " ++ s ++ " = " ++ r + | ARegMem n m r v i => r ++ " = " ++ "*(int" ++ f n ++ " *) (" ++ v ++ " + " ++ i ++ ")" + | AMemReg n m v i r => "*(int" ++ f n ++ " *) (" ++ v ++ " + " ++ i ++ ") = " ++ r + | ARegReg n a b => a ++ " = " ++ b + | AConstInt n r c => r ++ " = " ++ c + end. + + Coercion intOpToString (b: IntOp): string := + match b with + | IAdd => "+" + | ISub => "-" + | IXor => "^" + | IAnd => "&" + | IOr => "|" + end. + + Coercion dualOpToString (b: DualOp): string := + match b with + | Mult => "*" + end. + + Coercion carryOpToString (b: CarryOp): string := + match b with + | AddWithCarry => "+" + end. + + Coercion rotOpToString (r: RotOp): string := + match r with + | Shl => "<<" + | Shr => ">>" + end. + + Definition operationToString (op: Operation): option string := + let f := fun x => ( + if (Nat.eq_dec x 32) + then "32" + else if (Nat.eq_dec x 64) + then "64" + else "128") in + + match op with + | IOpConst n o r c => + r ++ " " ++ o ++ "= " ++ c + | IOpReg n o a b => + a ++ " " ++ o ++ "= " ++ b + | IOpMem n _ o a b i => + a ++ " " ++ o ++ "= *(int" ++ (f n) ++ "* " ++ b ++ " + " ++ i ++ ")" + | IOpStack n o a b => + a ++ " " ++ o ++ "= " ++ b + | DOp n o a b x => + match x with + | Some r => + "(int" ++ (f (2 * n)) ++ ") " ++ r ++ " " ++ a ++ " " ++ o ++ "= " ++ b + | None => a ++ " " ++ o ++ "= " ++ b + end + | COp n o a b => + a ++ " " ++ o ++ "= " ++ b + | ROp n o r i => + r ++ " " ++ o ++ "= " ++ i + end. + + Definition testOpToString (t: TestOp): bool * string := + match t with + | TEq => (true, "=") + | TLt => (true, "<") + | TGt => (true, ">") + | TLe => (false, ">") + | TGe => (false, "<") + end. + + Definition conditionalToString (c: Conditional): string * string := + match c with + | CTrue => ("=? 0", "=") + | CZero n r => ("=? " ++ r, "=") + | CReg n t a b => + match (testOpToString t) with + | (true, s) => + (s ++ "? " ++ a ++ " - " ++ b, s) + | (false, s) => + (s ++ "? " ++ a ++ " - " ++ b, "!" ++ s) + end + + | CConst n t a b => + match (testOpToString t) with + | (true, s) => + (s ++ "? " ++ a ++ " - " ++ b, s) + | (false, s) => + (s ++ "? " ++ a ++ " - " ++ b, "!" ++ s) + end + end. + + End Elements. + + Section Parsing. + Definition convM {n m} (x: list (Mapping n)): list (Mapping m). + destruct (Nat.eq_dec n m); subst. exact x. exact []. + Defined. + + Arguments regM [n] r. + Arguments stackM [n] s. + Arguments memM [n m] x i. + Arguments constM [n] x. + + Fixpoint entries (width: nat) (prog: list QhasmStatement): list (Mapping width) := + match prog with + | cons s next => + match s with + | QAssign a => + match a with + | ARegStack n r s => convM [regM r; stackM s] + | AStackReg n s r => convM [regM r; stackM s] + | ARegMem n m a b i => convM [regM a; memM b i] + | AMemReg n m a i b => convM [memM a i; regM b] + | ARegReg n a b => convM [regM a; regM b] + | AConstInt n r c => convM [regM r; constM c] + end + | QOp o => + match o with + | IOpConst _ o a c => convM [regM a; constM c] + | IOpReg _ o a b => convM [regM a; regM b] + | IOpStack _ o a b => convM [regM a; stackM b] + | IOpMem _ _ o a b i => convM [regM a; memM b i] + | DOp _ o a b (Some x) => convM [regM a; regM b; regM x] + | DOp _ o a b None => convM [regM a; regM b] + | ROp _ o a i => convM [regM a] + | COp _ o a b => convM [regM a; regM b] + end + | QCond c _ => + match c with + | CTrue => [] + | CZero n r => convM [regM r] + | CReg n o a b => convM [regM a; regM b] + | CConst n o a c => convM [regM a; constM c] + end + | _ => [] + end ++ (entries width next) + | nil => nil + end. + + Definition flatMapOpt {A B} (lst: list A) (f: A -> option B): list B := + fold_left + (fun lst a => match (f a) with | Some x => cons x lst | _ => lst end) + lst []. + + Definition flatMapList {A B} (lst: list A) (f: A -> list B): list B := + fold_left (fun lst a => lst ++ (f a)) lst []. + + Fixpoint dedup {n} (l : list (Mapping n)) : list (Mapping n) := + match l with + | [] => [] + | x::xs => + if in_dec EvalUtil.mapping_dec x xs + then dedup xs + else x::(dedup xs) + end. + + Definition getRegNames (n: nat) (lst: list (Mapping n)): list nat := + flatMapOpt (dedup lst) (fun e => + match e with | regM (reg _ _ x) => Some x | _ => None end). + + Definition getStackNames (n: nat) (lst: list (Mapping n)): list nat := + flatMapOpt (dedup lst) (fun e => + match e with | stackM (stack _ _ x) => Some x | _ => None end). + + Definition getMemNames (n: nat) (lst: list (Mapping n)): list nat := + flatMapOpt (dedup lst) (fun e => + match e with | memM _ (mem _ _ _ x) _ => Some x | _ => None end). + + Fixpoint getInputs' (n: nat) (prog: list QhasmStatement) (init: list (Mapping n)): list (Mapping n) := + let f := fun rs => filter (fun x => + negb (proj1_sig (bool_of_sumbool (in_dec EvalUtil.mapping_dec x init)))) rs in + let g := fun {w} p => (@convM w n (fst p), @convM w n (snd p)) in + match prog with + | [] => [] + | cons p ps => + let requiredCommaUsed := match p with + | QAssign a => + match a with + | ARegStack n r s => g ([stackM s], [regM r; stackM s]) + | AStackReg n s r => g ([regM r], [regM r; stackM s]) + | ARegMem n m r x i => g ([memM x i], [regM r; memM x i]) + | AMemReg n m x i r => g ([regM r], [regM r; memM x i]) + | ARegReg n a b => g ([regM b], [regM a; regM b]) + | AConstInt n r c => g ([], [regM r]) + end + | QOp o => + match o with + | IOpConst _ o a c => g ([regM a], [regM a]) + | IOpReg _ o a b => g ([regM a], [regM a; regM b]) + | IOpStack _ o a b => g ([regM a], [regM a; stackM b]) + | IOpMem _ _ o a b i => g ([regM a], [regM a; memM b i]) + | DOp _ o a b (Some x) => g ([regM a; regM b], [regM a; regM b; regM x]) + | DOp _ o a b None => g ([regM a; regM b], [regM a; regM b]) + | ROp _ o a i => g ([regM a], [regM a]) + | COp _ o a b => g ([regM a], [regM a; regM b]) + end + | QCond c _ => + match c with + | CTrue => ([], []) + | CZero n r => g ([], [regM r]) + | CReg n o a b => g ([], [regM a; regM b]) + | CConst n o a c => g ([], [regM a]) + end + | _ => ([], []) + end in match requiredCommaUsed with + | (r, u) => ((f r) ++ (getInputs' n ps ((f u) ++ init))) + end + end. + + Definition getInputs (n: nat) (prog: list QhasmStatement) := getInputs' n prog []. + + Definition mappingDeclaration {n} (x: Mapping n): option string := + match x with + | regM (reg _ w x) => + match w with + | W32 => Some ("int32 " ++ (reg w x))%string + | W64 => Some ("int64 " ++ (reg w x))%string + end + + | stackM (stack _ w x) => + match w with + | W32 => Some ("stack32 " ++ (stack w x))%string + | W64 => Some ("stack64 " ++ (stack w x))%string + end + + | memM _ (mem _ m w x) _ => + match w with + | W32 => Some ("stack32 " ++ (@mem _ m w x))%string + | W64 => Some ("stack64 " ++ (@mem _ m w x))%string + end + + | _ => None + end. + + Definition inputDeclaration {n} (x: Mapping n): option string := + match x with + | regM r => Some ("input " ++ r)%string + | stackM s => Some ("input " ++ s)%string + | memM _ m i => Some ("input " ++ m)%string + | _ => None + end. + + End Parsing. + + (* Macroscopic Conversion Methods *) + Definition optionToList {A} (o: option A): list A := + match o with + | Some a => [a] + | None => [] + end. + + Definition convertStatement (statement: QhasmStatement): list string := + match statement with + | QAssign a => optionToList (assignmentToString a) + | QOp o => optionToList (operationToString o) + | QCond c l => + match (conditionalToString c) with + | (s1, s2) => + let s' := ("goto lbl" ++ l ++ " if " ++ s2)%string in + [s1; s'] + end + | QLabel l => [("lbl" ++ l ++ ": ")%string] + | QCall l => [("push %eip+2")%string; ("goto" ++ l)%string] + | QRet => [("pop %eip")%string] + end. + + Transparent Qhasm.Program QhasmString.Program. + + Definition convertProgram x y (prog: Qhasm.Program x): option (QhasmString.Program y) := + let decls := fun x => flatMapList (dedup (entries x prog)) + (compose optionToList mappingDeclaration) in + + let inputs := fun x => flatMapList (getInputs x prog) + (compose optionToList inputDeclaration) in + + let stmts := (flatMapList prog convertStatement) in + let enter := [("enter prog")%string] in + let leave := [("leave")%string] in + let blank := [EmptyString] in + let newline := String (ascii_of_nat 10) EmptyString in + + Some (fold_left (fun x y => (x ++ newline ++ y)%string) + (decls 32 ++ inputs 32 ++ + decls 64 ++ inputs 64 ++ blank ++ + enter ++ blank ++ + stmts ++ blank ++ + leave ++ blank) EmptyString). + + Lemma convert_spec: forall pa pb a a' b b' prog prog', + convertProgram pa pb prog = Some prog' -> + convertState pa pb a = Some a' -> + convertState pa pb b = Some b' -> + QhasmString.evaluatesTo pb prog' a b <-> Qhasm.evaluatesTo pa prog a' b'. + Admitted. + +End StringConversion. diff --git a/src/Assembly/Vectorize.v b/src/Assembly/Vectorize.v new file mode 100644 index 000000000..d2fca3ce6 --- /dev/null +++ b/src/Assembly/Vectorize.v @@ -0,0 +1,122 @@ +Require Export Bedrock.Word Bedrock.Nomega. +Require Import NPeano NArith PArith Ndigits Compare_dec Arith. +Require Import ProofIrrelevance Ring List Omega. + +Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := + let y := x in f y. + +Notation "'plet' x := y 'in' z" := (Let_In y (fun x => z)) (at level 60). + +Section Vector. + Import ListNotations. + + Definition vec T n := {x: list T | length x = n}. + + Definition vget {n T} (x: vec T n) (i: {v: nat | (v < n)%nat}): T. + refine ( + match (proj1_sig x) as x' return (proj1_sig x) = x' -> _ with + | [] => fun _ => _ + | x0 :: xs => fun _ => nth (proj1_sig i) (proj1_sig x) x0 + end eq_refl); + abstract ( + destruct x as [x xp], i as [i ip]; destruct x as [|x0 xs]; + simpl in *; subst; try omega; + match goal with + | [H: _ = @nil _ |- _] => inversion H + end). + Defined. + + Lemma vget_spec: forall {T n} (x: vec T n) (i: {v: nat | (v < n)%nat}) (d: T), + vget x i = nth (proj1_sig i) (proj1_sig x) d. + Proof. + intros; destruct x as [x xp], i as [i ip]; + destruct x as [|x0 xs]; induction i; unfold vget; simpl; + intuition; try (simpl in xp; subst; omega); + induction n; simpl in xp; try omega; clear IHi IHn. + + apply nth_indep. + assert (length xs = n) by omega; subst. + omega. + Qed. + + Definition vec0 {T} : vec T 0. + refine (exist _ [] _); abstract intuition. + Defined. + + Lemma lift0: forall {T n} (x: T), vec (word n) 0 -> T. + intros; refine x. + Defined. + + Lemma liftS: forall {T n m} (f: vec (word n) m -> word n -> T), + (vec (word n) (S m) -> T). + Proof. + intros T n m f v; destruct v as [v p]; induction m, v; + try (abstract (inversion p)). + + - refine (f (exist _ [] _) w); abstract intuition. + - refine (f (exist _ v _) w); abstract intuition. + Defined. + + Lemma vecToList: forall T n m (f: vec (word n) m -> T), + (list (word n) -> option T). + Proof. + intros T n m f x; destruct (Nat.eq_dec (length x) m). + + - refine (Some (f (exist _ x _))); abstract intuition. + - refine None. + Defined. +End Vector. + +Section Vectorization. + Import ListNotations. + + Lemma detuple_let: forall {A B C} (y0: A) (y1: B) (z: (A * B) -> C), + Let_In (y0, y1) z = + Let_In y0 (fun x0 => + Let_In y1 (fun x1 => + z (x0, x1))). + Proof. intros; unfold Let_In; cbv zeta; intuition. Qed. + + Lemma listize_let: forall {A B} (y d: A) (z: A -> B), + Let_In y z = Let_In [y] (fun x => z (nth 0 x d)). + Proof. intros; unfold Let_In; cbv zeta; intuition. Qed. + + Lemma combine_let_lists: forall {A B} (a: list A) (b: list A) (d: A) (z: list A -> list A -> B), + Let_In a (fun x => Let_In b (z x)) = + Let_In (a ++ b) (fun x => z (firstn (length a) x) (skipn (length a) x)). + Proof. + + intros; unfold Let_In; cbv zeta. + + assert (forall b0, firstn (length a) (a ++ b0) = a) as HA. { + induction a; intros; simpl; try reflexivity. + apply f_equal; apply IHa. + } + + assert (forall b0, skipn (length a) (a ++ b0) = b0) as HB. { + induction a; intros; simpl; try reflexivity. + apply IHa; intro; simpl in HA. + pose proof (HA b1) as HA'; inversion HA' as [HA'']. + rewrite HA''. + assumption. + } + + rewrite HA, HB; reflexivity. + Qed. + +End Vectorization. + +Ltac vectorize := + repeat match goal with + | [ |- context[?a - 1] ] => + let c := eval simpl in (a - 1) in + replace (a - 1) with c by omega + | [ |- vec (word ?n) O -> ?T] => apply (@lift0 T n) + | [ |- vec (word ?n) ?m -> ?T] => apply (@liftS T n (m - 1)) + end. + +Section Examples. + Lemma vectorize_example: (vec (word 32) 2 -> word 32). + vectorize; refine (@wplus 32). + Qed. +End Examples. diff --git a/src/Assembly/Wordize.v b/src/Assembly/Wordize.v new file mode 100644 index 000000000..bac25db71 --- /dev/null +++ b/src/Assembly/Wordize.v @@ -0,0 +1,501 @@ + +Require Export Bedrock.Word Bedrock.Nomega. +Require Import NArith PArith Ndigits Nnat NPow NPeano Ndec. +Require Import Compare_dec Omega. +Require Import FunctionalExtensionality ProofIrrelevance. +Require Import QhasmUtil QhasmEvalCommon. + +Hint Rewrite wordToN_nat Nat2N.inj_add N2Nat.inj_add + Nat2N.inj_mul N2Nat.inj_mul Npow2_nat : N. + +Open Scope nword_scope. + +Section WordizeUtil. + Lemma break_spec: forall (m n: nat) (x: word n) low high, + (low, high) = break m x + -> &x = (&high * Npow2 m + &low)%N. + Proof. + intros; unfold break in *; destruct (le_dec m n); + inversion H; subst; clear H; simpl. + Admitted. + + Lemma mask_wand : forall (n: nat) (x: word n) m b, + (& (mask (N.to_nat m) x) < b)%N + -> (& (x ^& (@NToWord n (N.ones m))) < b)%N. + Proof. + Admitted. + + Lemma convS_id: forall A x p, x = (@convS A A x p). + Proof. + intros; unfold convS; vm_compute. + replace p with (eq_refl A); intuition. + apply proof_irrelevance. + Qed. + + Lemma word_param_eq: forall n m, word n = word m -> n = m. + Proof. (* TODO: How do we prove this *) Admitted. + + Lemma word_conv_eq: forall {n m} (y: word m) p, + &y = &(@convS (word m) (word n) y p). + Proof. + intros. + revert p. + destruct (Nat.eq_dec n m). + + - rewrite e; intros; apply f_equal; apply convS_id. + + - intros; contradict n0. + apply word_param_eq; rewrite p; intuition. + Qed. + + Lemma to_nat_lt: forall x b, (x < b)%N <-> (N.to_nat x < N.to_nat b)%nat. + Proof. (* via Nat2N.inj_compare *) Admitted. + + Lemma of_nat_lt: forall x b, (x < b)%nat <-> (N.of_nat x < N.of_nat b)%N. + Proof. (* via N2Nat.inj_compare *) Admitted. + + Lemma Npow2_spec : forall n, Npow2 n = N.pow 2 (N.of_nat n). + Proof. (* by induction and omega *) Admitted. + + Lemma NToWord_wordToN: forall sz x, NToWord sz (wordToN x) = x. + Proof. + intros. + rewrite NToWord_nat. + rewrite wordToN_nat. + rewrite Nat2N.id. + rewrite natToWord_wordToNat. + intuition. + Qed. + + Lemma wordToN_NToWord: forall sz x, (x < Npow2 sz)%N -> wordToN (NToWord sz x) = x. + Proof. + intros. + rewrite NToWord_nat. + rewrite wordToN_nat. + rewrite <- (N2Nat.id x). + apply Nat2N.inj_iff. + rewrite Nat2N.id. + apply natToWord_inj with (sz:=sz); + try rewrite natToWord_wordToNat; + intuition. + + - apply wordToNat_bound. + - rewrite <- Npow2_nat; apply to_nat_lt; assumption. + Qed. + + Lemma word_size_bound : forall {n} (w: word n), (&w < Npow2 n)%N. + Proof. + intros; pose proof (wordToNat_bound w) as B; + rewrite of_nat_lt in B; + rewrite <- Npow2_nat in B; + rewrite N2Nat.id in B; + rewrite <- wordToN_nat in B; + assumption. + Qed. + + Lemma Npow2_gt0 : forall x, (0 < Npow2 x)%N. + Proof. + intros; induction x. + + - simpl; apply N.lt_1_r; intuition. + + - replace (Npow2 (S x)) with (2 * (Npow2 x))%N by intuition. + apply (N.lt_0_mul 2 (Npow2 x)); left; split; apply N.neq_0_lt_0. + + + intuition; inversion H. + + + apply N.neq_0_lt_0 in IHx; intuition. + Qed. + + Lemma natToWord_convS: forall {n m} (x: word n) p, + & x = & @convS (word n) (word m) x p. + Proof. Admitted. + + Lemma natToWord_combine: forall {n} (x: word n) k, + & x = & combine x (wzero k). + Proof. Admitted. + + Lemma natToWord_split1: forall {n} (x: word n) p, + & x = & split1 n 0 (convS x p). + Proof. Admitted. + + Lemma extend_bound: forall k n (p: (k <= n)%nat) (w: word k), + (& (extend p w) < Npow2 k)%N. + Proof. + intros. + assert (n = k + (n - k)) by abstract omega. + replace (& (extend p w)) with (& w); try apply word_size_bound. + unfold extend. + rewrite <- word_conv_eq. + unfold zext. + clear; revert w; induction (n - k). + + - intros. + assert (word k = word (k + 0)) as Z by intuition. + replace w with (split1 k 0 (convS w Z)). + replace (wzero 0) with (split2 k 0 (convS w Z)). + rewrite <- natToWord_split1 with (p := Z). + rewrite combine_split. + apply natToWord_convS. + + + admit. + + admit. + + - intros; rewrite <- natToWord_combine; intuition. + Admitted. + + Lemma Npow2_split: forall a b, + (Npow2 (a + b) = (Npow2 a) * (Npow2 b))%N. + Proof. + intros; revert a. + induction b. + + - intros; simpl; replace (a + 0) with a; nomega. + + - intros. + replace (a + S b) with (S a + b) by intuition. + rewrite (IHb (S a)); simpl; clear IHb. + induction (Npow2 a), (Npow2 b); simpl; intuition. + rewrite Pos.mul_xO_r; intuition. + Qed. + + Lemma Npow2_ignore: forall {n} (x: word n), + x = NToWord _ (& x + Npow2 n). + Proof. Admitted. + +End WordizeUtil. + +(** Wordization Lemmas **) + +Section Wordization. + + Lemma wordize_plus': forall {n} (x y: word n) (b: N), + (b <= Npow2 n)%N + -> (&x < b)%N + -> (&y < (Npow2 n - b))%N + -> (&x + &y)%N = & (x ^+ y). + Proof. + intros. + unfold wplus, wordBin. + rewrite wordToN_NToWord; intuition. + apply (N.lt_le_trans _ (b + &y)%N _). + + - apply N.add_lt_le_mono; try assumption; intuition. + + - replace (Npow2 n) with (b + Npow2 n - b)%N by nomega. + replace (b + Npow2 n - b)%N with (b + (Npow2 n - b))%N by ( + replace (b + (Npow2 n - b))%N with ((Npow2 n - b) + b)%N by nomega; + rewrite (N.sub_add b (Npow2 n)) by assumption; + nomega). + + apply N.add_le_mono_l; try nomega. + apply N.lt_le_incl; assumption. + Qed. + + Lemma wordize_plus: forall {n} (x y: word n), + if (overflows n (&x + &y)%N) + then (&x + &y)%N = (& (x ^+ y) + Npow2 n)%N + else (&x + &y)%N = & (x ^+ y). + Proof. Admitted. + + Lemma wordize_awc: forall {n} (x y: word n) (c: bool), + if (overflows n (&x + &y + (if c then 1 else 0))%N) + then (&x + &y + (if c then 1 else 0))%N = (&(addWithCarry x y c) + Npow2 n)%N + else (&x + &y + (if c then 1 else 0))%N = &(addWithCarry x y c). + Proof. Admitted. + + Lemma wordize_mult': forall {n} (x y: word n) (b: N), + (1 < n)%nat -> (0 < b)%N + -> (&x < b)%N + -> (&y < (Npow2 n) / b)%N + -> (&x * &y)%N = & (x ^* y). + Proof. + intros; unfold wmult, wordBin. + rewrite wordToN_NToWord; intuition. + apply (N.lt_le_trans _ (b * ((Npow2 n) / b))%N _). + + - apply N.mul_lt_mono; assumption. + + - apply N.mul_div_le; nomega. + Qed. + + Lemma wordize_mult: forall {n} (x y: word n) (b: N), + (&x * &y)%N = (&(x ^* y) + + &((EvalUtil.highBits (n/2) x) ^* (EvalUtil.highBits (n/2) y)) * Npow2 n)%N. + Proof. intros. Admitted. + + Lemma wordize_and: forall {n} (x y: word n), + N.land (&x) (&y) = & (x ^& y). + Proof. + intros; pose proof (Npow2_gt0 n). + pose proof (word_size_bound x). + pose proof (word_size_bound y). + + induction n. + + - rewrite (shatter_word_0 x) in *. + rewrite (shatter_word_0 y) in *. + simpl; intuition. + + - rewrite (shatter_word x) in *. + rewrite (shatter_word y) in *. + induction (whd x), (whd y). + + + admit. + + admit. + + admit. + + admit. + Admitted. + + Lemma wordize_shiftr: forall {n} (x: word n) (k: nat), + (N.shiftr_nat (&x) k) = & (shiftr x k). + Proof. Admitted. + +End Wordization. + +Section Bounds. + + Theorem constant_bound_N : forall {n} (k: word n), + (& k < & k + 1)%N. + Proof. intros; nomega. Qed. + + Theorem constant_bound_nat : forall (n k: nat), + (N.of_nat k < Npow2 n)%N + -> (& (@natToWord n k) < (N.of_nat k) + 1)%N. + Proof. + intros. + rewrite wordToN_nat. + rewrite wordToNat_natToWord_idempotent; + try assumption; nomega. + Qed. + + Lemma let_bound : forall {n} (x: word n) (f: word n -> word n) xb fb, + (& x < xb)%N + -> (forall x', & x' < xb -> & (f x') < fb)%N + -> ((let k := x in &(f k)) < fb)%N. + Proof. intros; eauto. Qed. + + Definition Nlt_dec (x y: N): {(x < y)%N} + {(x >= y)%N}. + refine ( + let c := N.compare x y in + match c as c' return c = c' -> _ with + | Lt => fun _ => left _ + | _ => fun _ => right _ + end eq_refl); + abstract ( + unfold c, N.ge, N.lt in *; intuition; subst; + match goal with + | [H0: ?x = _, H1: ?x = _ |- _] => + rewrite H0 in H1; inversion H1 + end). + Defined. + + Theorem wplus_bound : forall {n} (w1 w2 : word n) b1 b2, + (&w1 < b1)%N + -> (&w2 < b2)%N + -> (&(w1 ^+ w2) < b1 + b2)%N. + Proof. + intros. + + destruct (Nlt_dec (b1 + b2)%N (Npow2 n)); + rewrite <- wordize_plus' with (b := b1); + try apply N.add_lt_mono; + try assumption. + + (* A couple inequality subgoals *) + Admitted. + + Theorem wmult_bound : forall {n} (w1 w2 : word n) b1 b2, + (1 < n)%nat + -> (&w1 < b1)%N + -> (&w2 < b2)%N + -> (&(w1 ^* w2) < b1 * b2)%N. + Proof. + intros. + destruct (Nlt_dec (b1 * b2)%N (Npow2 n)); + rewrite <- wordize_mult' with (b := b1); + try apply N.mul_lt_mono; + try assumption; + try nomega. + + (* A couple inequality subgoals *) + Admitted. + + Theorem shiftr_bound : forall {n} (w : word n) b bits, + (&w < b)%N + -> (&(shiftr w bits) < N.succ (N.shiftr_nat b bits))%N. + Proof. + intros. + assert (& shiftr w bits <= N.shiftr_nat b bits)%N. { + rewrite <- wordize_shiftr. + induction bits; unfold N.shiftr_nat in *; simpl; intuition. + + - unfold N.le, N.lt in *; rewrite H; intuition; inversion H0. + + - revert IHbits; + + admit. (* Monotonicity of N.div2 *) + } + + apply N.le_lteq in H0; destruct H0; nomega. + Admitted. + + Theorem mask_bound : forall {n} (w : word n) m, + (n > 1)%nat -> + (&(mask m w) < Npow2 m)%N. + Proof. + intros. + unfold mask in *; destruct (le_dec m n); simpl; + try apply extend_bound. + + pose proof (word_size_bound w). + apply (N.le_lt_trans _ (Npow2 n) _). + + - unfold N.le, N.lt in *; rewrite H0; intuition; inversion H1. + + - clear H H0. + replace m with ((m - n) + n) by nomega. + replace (Npow2 n) with (1 * (Npow2 n))%N + by (rewrite N.mul_comm; nomega). + rewrite Npow2_split. + apply N.mul_lt_mono_pos_r. + + + apply Npow2_gt0. + + + assert (0 < m - n)%nat by omega. + induction (m - n); try inversion H; try abstract ( + simpl; replace 2 with (S 1) by omega; + apply N.lt_1_2). + + assert (0 < n1)%nat as Z by omega; apply IHn1 in Z. + apply (N.le_lt_trans _ (Npow2 n1) _). + + * admit. + * admit. + Admitted. + + Theorem mask_update_bound : forall {n} (w : word n) b m, + (n > 1)%nat + -> (&w < b)%N + -> (&(mask m w) < (N.min b (Npow2 m)))%N. + Proof. + intros; unfold mask, N.min; + destruct (le_dec m n), + (N.compare b (Npow2 m)); + simpl; try assumption. + + Admitted. + +End Bounds. + +(** Wordization Tactics **) + +Ltac wordize_ast := + repeat match goal with + | [ H: (& ?x < ?b)%N |- context[((& ?x) + (& ?y))%N] ] => rewrite (wordize_plus' x y b) + | [ H: (& ?x < ?b)%N |- context[((& ?x) * (& ?y))%N] ] => rewrite (wordize_mult' x y b) + | [ |- context[N.land (& ?x) (& ?y)] ] => rewrite (wordize_and x y) + | [ |- context[N.shiftr (& ?x) ?k] ] => rewrite (wordize_shiftr x k) + | [ |- (_ < _ / _)%N ] => unfold N.div; simpl + | [ |- context[Npow2 _] ] => simpl + | [ |- (?x < ?c)%N ] => assumption + | [ |- _ = _ ] => reflexivity + end. + +Ltac lt_crush := try abstract (clear; vm_compute; intuition). + +(** Bounding Tactics **) + +Ltac multi_apply0 A L := pose proof (L A). + +Ltac multi_apply1 A L := + match goal with + | [ H: A < ?b |- _] => pose proof (L A b H) + end. + +Ltac multi_apply2 A B L := + match goal with + | [ H1: A < ?b1, H2: B < ?b2 |- _] => pose proof (L A B b1 b2 H1 H2) + end. + +Ltac multi_recurse n T := + match goal with + | [ H: (T < _)%N |- _] => idtac + | _ => + is_var T; + let T' := (eval cbv delta [T] in T) in multi_recurse n T'; + match goal with + | [ H : T' < ?x |- _ ] => + pose proof (H : T < x) + end + + | _ => + match T with + | ?W1 ^+ ?W2 => + multi_recurse n W1; multi_recurse n W2; + multi_apply2 W1 W2 (@wplus_bound n) + + | ?W1 ^* ?W2 => + multi_recurse n W1; multi_recurse n W2; + multi_apply2 W1 W2 (@wmult_bound n) + + | mask ?m ?w => + multi_recurse n w; + multi_apply1 w (fun b => @mask_update_bound n w b) + + | mask ?m ?w => + multi_recurse n w; + pose proof (@mask_bound n w m) + + | ?x ^& (@NToWord _ (N.ones ?m)) => + multi_recurse n (mask (N.to_nat m) x); + match goal with + | [ H: (& (mask (N.to_nat m) x) < ?b)%N |- _] => + pose proof (@mask_wand n x m b H) + end + + | shiftr ?w ?bits => + multi_recurse n w; + match goal with + | [ H: (w < ?b)%N |- _] => + pose proof (@shiftr_bound n w b bits H) + end + + | NToWord _ ?k => pose proof (@constant_bound_N n k) + | natToWord _ ?k => pose proof (@constant_bound_nat n k) + | _ => pose proof (@word_size_bound n T) + end + end. + +Lemma unwrap_let: forall {n} (y: word n) (f: word n -> word n) (b: N), + (&(let x := y in f x) < b)%N <-> let x := y in (&(f x) < b)%N. +Proof. intuition. Qed. + +Ltac multi_bound n := + match goal with + | [|- let A := ?B in _] => + multi_recurse n B; intro; multi_bound n + | [|- ((let A := _ in _) < _)%N] => + apply unwrap_let; multi_bound n + | [|- (?W < _)%N ] => + multi_recurse n W + end. + +(** Examples **) + +Module WordizationExamples. + + Lemma wordize_example0: forall (x y z: word 16), + (wordToN x < 10)%N -> + (wordToN y < 10)%N -> + (wordToN z < 10)%N -> + & (x ^* y) = (&x * &y)%N. + Proof. + intros. + wordize_ast; lt_crush. + transitivity 10%N; try assumption; lt_crush. + Qed. + +End WordizationExamples. + +Close Scope nword_scope. diff --git a/src/BaseSystem.v b/src/BaseSystem.v index c07aad759..1985520f0 100644 --- a/src/BaseSystem.v +++ b/src/BaseSystem.v @@ -2,6 +2,7 @@ Require Import Coq.Lists.List. 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. +Require Import Crypto.Util.Notations. Import Nat. Local Open Scope Z. @@ -47,7 +48,7 @@ Section BaseSystem. | _, nil => us | _, _ => vs end. - Infix ".+" := add (at level 50). + Infix ".+" := add. Hint Extern 1 (@eq Z _ _) => ring. diff --git a/src/BaseSystemProofs.v b/src/BaseSystemProofs.v index 4414877b4..85835aabe 100644 --- a/src/BaseSystemProofs.v +++ b/src/BaseSystemProofs.v @@ -3,9 +3,10 @@ Require Import Util.ListUtil Util.CaseUtil Util.ZUtil. Require Import ZArith.ZArith ZArith.Zdiv. Require Import Omega NPeano Arith. Require Import Crypto.BaseSystem. +Require Import Crypto.Util.Notations. Local Open Scope Z. -Local Infix ".+" := add (at level 50). +Local Infix ".+" := add. Local Hint Extern 1 (@eq Z _ _) => ring. diff --git a/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v b/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v index f70479c3a..e3809bb8a 100644 --- a/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v +++ b/src/CompleteEdwardsCurve/CompleteEdwardsCurveTheorems.v @@ -1,47 +1,34 @@ 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. +Require Import Crypto.Util.Notations. 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). + 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 +42,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] + | |- Decidable.Decidable _ => solve [ typeclasses eauto ] + 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..364d7f9ec 100644 --- a/src/CompleteEdwardsCurve/ExtendedCoordinates.v +++ b/src/CompleteEdwardsCurve/ExtendedCoordinates.v @@ -1,194 +1,169 @@ -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. +Require Import Crypto.Util.Notations. + +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). + 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). + Global Instance DecidableRel_eq : Decidable.DecidableRel eq. + Proof. typeclasses eauto. Qed. + + 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. + + Definition zero : point := from_twisted E.zero. + Definition opp P : point := from_twisted (E.opp (to_twisted P)). + Lemma extended_group : @group point eq add zero opp. + Proof. + eapply @isomorphism_to_subgroup_group; eauto with typeclass_instances core. + - apply DecidableRel_eq. + - unfold opp. repeat intro. match goal with [H:_|-_] => rewrite H; reflexivity end. + - intros. apply to_twisted_add. + - unfold opp; intros; rewrite to_twisted_from_twisted; reflexivity. + - unfold zero; intros; rewrite to_twisted_from_twisted; reflexivity. + 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 +185,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 4ef01c37b..133a21605 100644 --- a/src/CompleteEdwardsCurve/Pre.v +++ b/src/CompleteEdwardsCurve/Pre.v @@ -1,67 +1,33 @@ -Require Import Coq.ZArith.BinInt Coq.ZArith.Znumtheory Crypto.Tactics.VerdiTactics. -Require Import Coq.omega.Omega. - -Require Import Crypto.Spec.ModularArithmetic. -Require Import Crypto.ModularArithmetic.PrimeFieldTheorems. -Local Open Scope Z_scope. -Local Open Scope F_scope. +Require Import Coq.Classes.Morphisms. Require Coq.Setoids.Setoid. +Require Import Crypto.Algebra Crypto.Tactics.Nsatz. +Require Import Crypto.Util.Notations. +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). + + 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 onCurve_subst : forall x1 x2 y1 y2, and (eq x1 y1) (eq x2 y2) -> onCurve (x1, x2) -> onCurve (y1, y2). @@ -72,125 +38,74 @@ Section Pre. Qed. 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. + onCurve (x1, y1) -> onCurve (x2, y2) -> (1 - d*x1*x2*y1*y2) <> 0. + Proof. intros H1 H2 ?. apply (edwardsAddComplete' _ _ _ _ H1 H2); field_algebra. Qed. - Definition zeroOnCurve : onCurve (0, 1). - simpl. field. - Qed. + Lemma zeroOnCurve : onCurve (0, 1). Proof. simpl. field_algebra. 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). + 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; cbv beta iota; 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. +End Pre. - Lemma unifiedAdd'_onCurve : forall P1 P2, onCurve P1 -> onCurve P2 -> - onCurve (unifiedAdd' P1 P2). +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. +End RespectsFieldHomomorphism. 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/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 6168f88bd..8e526745c 100644 --- a/src/ModularArithmetic/ModularArithmeticTheorems.v +++ b/src/ModularArithmetic/ModularArithmeticTheorems.v @@ -150,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. diff --git a/src/ModularArithmetic/ModularBaseSystem.v b/src/ModularArithmetic/ModularBaseSystem.v index 9c6a58f9a..08545bdb4 100644 --- a/src/ModularArithmetic/ModularBaseSystem.v +++ b/src/ModularArithmetic/ModularBaseSystem.v @@ -7,15 +7,16 @@ Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParams. Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParamProofs. Require Import Crypto.ModularArithmetic.ExtendedBaseVector. Require Import Crypto.Tactics.VerdiTactics. +Require Import Crypto.Util.Notations. 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. - Local Notation "u '~=' x" := (rep u x) (at level 70). + Local Notation "u ~= x" := (rep u x). Local Hint Unfold rep. Definition encode (x : F modulus) := encode x ++ BaseSystem.zeros (length base - 1)%nat. @@ -35,13 +36,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,7 +55,7 @@ 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. @@ -110,12 +111,12 @@ Section Canonicalization. end. Definition and_term us := if isFull us then max_ones else 0. - + Definition freeze us := let us' := carry_full (carry_full (carry_full us)) 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. *) 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 c0e942ece..116fe10e5 100644 --- a/src/ModularArithmetic/ModularBaseSystemOpt.v +++ b/src/ModularArithmetic/ModularBaseSystemOpt.v @@ -76,7 +76,7 @@ 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 => @@ -91,7 +91,7 @@ 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. @@ -207,7 +207,7 @@ Section Carries. 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. @@ -239,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. @@ -273,7 +273,7 @@ Section Carries. rewrite carry_sequence_opt_cps_correct by 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. @@ -502,7 +502,7 @@ Section Multiplication. rewrite map_shiftl by apply k_nonneg. rewrite c_subst. rewrite k_subst. - change @map with @map_opt. + change @map with @map_opt. change @Z_shiftl_by with @Z_shiftl_by_opt. reflexivity. Defined. @@ -640,7 +640,7 @@ Section Canonicalization. := 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 us -> PseudoMersenneBaseRep.rep us x -> @pre_carry_bounds _ _ int_width vs -> PseudoMersenneBaseRep.rep vs x -> freeze_opt us = freeze_opt vs. Proof. diff --git a/src/ModularArithmetic/ModularBaseSystemProofs.v b/src/ModularArithmetic/ModularBaseSystemProofs.v index 562c7d6d4..6f82a8950 100644 --- a/src/ModularArithmetic/ModularBaseSystemProofs.v +++ b/src/ModularArithmetic/ModularBaseSystemProofs.v @@ -6,15 +6,16 @@ Require Import VerdiTactics. Require Crypto.BaseSystem. Require Import Crypto.ModularArithmetic.ModularBaseSystem Crypto.ModularArithmetic.PrimeFieldTheorems. Require Import Crypto.BaseSystemProofs Crypto.ModularArithmetic.PseudoMersenneBaseParams Crypto.ModularArithmetic.PseudoMersenneBaseParamProofs Crypto.ModularArithmetic.ExtendedBaseVector. +Require Import Crypto.Util.Notations. Local Open Scope Z_scope. Section PseudoMersenneProofs. Context `{prm :PseudoMersenneBaseParams}. Local Hint Unfold decode. - Local Notation "u '~=' x" := (rep u x) (at level 70). - Local Notation "u '.+' x" := (add u x) (at level 70). - Local Notation "u '.*' x" := (ModularBaseSystem.mul u x) (at level 70). + Local Notation "u ~= x" := (rep u x). + Local Notation "u .+ x" := (add u x). + Local Notation "u .* x" := (ModularBaseSystem.mul u x). Local Hint Unfold rep. Lemma rep_decode : forall us x, us ~= x -> decode us = x. @@ -256,7 +257,7 @@ End PseudoMersenneProofs. Section CarryProofs. Context `{prm : PseudoMersenneBaseParams}. - Local Notation "u '~=' x" := (rep u x) (at level 70). + Local Notation "u ~= x" := (rep u x). Hint Unfold log_cap. Lemma base_length_lt_pred : (pred (length base) < length base)%nat. @@ -418,7 +419,7 @@ Section CarryProofs. End CarryProofs. Section CanonicalizationProofs. - Context `{prm : PseudoMersenneBaseParams} (lt_1_length_base : (1 < length base)%nat) + 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 *) @@ -783,7 +784,7 @@ Section CanonicalizationProofs. add_set_nth; [ zero_bounds | ]; apply IHj; auto; omega. Qed. - Ltac carry_seq_lower_bound := + 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) -> @@ -988,7 +989,7 @@ 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]). - + zero_bounds. + + zero_bounds. - eapply carry_full_2_bounds_0; eauto. - eapply carry_full_bounds; eauto; carry_length_conditions. carry_seq_lower_bound. @@ -1097,7 +1098,7 @@ Section CanonicalizationProofs. [ 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. + assert (0 < S i < length base)%nat by omega. intuition; right. apply carry_carry_done_done; try solve [carry_length_conditions]. assumption. @@ -1123,7 +1124,7 @@ Section CanonicalizationProofs. unfold carry, carry_and_reduce; break_if; try omega; intros. add_set_nth. split. - + zero_bounds. + + 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))). @@ -1138,12 +1139,12 @@ Section CanonicalizationProofs. ring_simplify. apply carry_full_2_bounds_same; auto. - match goal with H0 : (pred (length base) < length base)%nat, - H : carry_done _ |- _ => + 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. assert (0 < length base)%nat as zero_lt_length by omega. - match goal with H : carry_done _ |- _ => + match goal with H : carry_done _ |- _ => destruct (H 0%nat zero_lt_length) end. assumption. Qed. @@ -1277,7 +1278,7 @@ Section CanonicalizationProofs. 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 = + 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. @@ -1487,7 +1488,7 @@ Section CanonicalizationProofs. 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 | ]. @@ -1660,7 +1661,7 @@ Section CanonicalizationProofs. 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 := @@ -1813,7 +1814,7 @@ Section CanonicalizationProofs. 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) => + + 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. @@ -1923,11 +1924,11 @@ Section CanonicalizationProofs. - rewrite nth_default_modulus_digits in *. repeat (break_if; try omega). * subst. - match goal with H : isFull' _ _ _ = true |- _ => + 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 |- _ => + * 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. @@ -2065,7 +2066,7 @@ Section CanonicalizationProofs. us = vs. Proof. intros. - match goal with Hrep1 : rep _ ?x, Hrep2 : rep _ ?x |- _ => + 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. @@ -2076,7 +2077,7 @@ Section CanonicalizationProofs. Qed. Lemma freeze_canonical : forall us vs x, - pre_carry_bounds us -> rep us x -> + pre_carry_bounds us -> rep us x -> pre_carry_bounds vs -> rep vs x -> freeze us = freeze vs. Proof. @@ -2086,4 +2087,4 @@ Section CanonicalizationProofs. eapply minimal_rep_unique; eauto; rewrite freeze_length; assumption. Qed. -End CanonicalizationProofs.
\ No newline at end of file +End CanonicalizationProofs. 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 10bbdf33d..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. @@ -117,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. @@ -138,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. @@ -178,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. @@ -226,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/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 2ad3877ac..f6db1c14f 100644 --- a/src/Spec/CompleteEdwardsCurve.v +++ b/src/Spec/CompleteEdwardsCurve.v @@ -1,47 +1,44 @@ -Require Coq.ZArith.BinInt Coq.ZArith.Znumtheory. - Require Crypto.CompleteEdwardsCurve.Pre. -Require Import Crypto.Spec.ModularArithmetic. -Local Open Scope F_scope. - -Global Set Asymmetric Patterns. - -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 diff --git a/src/Spec/EdDSA.v b/src/Spec/EdDSA.v index 99f0766e0..c28ff0482 100644 --- a/src/Spec/EdDSA.v +++ b/src/Spec/EdDSA.v @@ -1,87 +1,92 @@ 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. +(** In Coq 8.4, we have [NPeano.pow] and [NPeano.modulo]. In Coq 8.5, + they are [Nat.pow] and [Nat.modulo]. To allow this file to work + with both versions, we create a module where we (locally) import + both [NPeano] and [Nat], and define the notations with unqualified + names. By importing the module, we get access to the notations + without importing [NPeano] and [Nat] in the top-level of this + file. *) + +Module Import Notations. + Import NPeano Nat. + + Infix "^" := pow. + Infix "mod" := modulo (at level 40, no associativity). + Infix "++" := Word.combine. +End Notations. + +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 *) + + {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 *) -Infix "^" := NPeano.pow. -Infix "mod" := NPeano.modulo. -Infix "++" := Word.combine. + {B : E} (* base point *) -Section EdDSAParams. + {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; - Class EdDSAParams := { (* <https://eprint.iacr.org/2015/677.pdf> *) - E : TwistedEdwardsParams; (* underlying elliptic curve *) + EdDSA_c_valid : c = 2 \/ c = 3; - 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_n_ge_c : n >= c; + EdDSA_n_le_b : n <= b; - H : forall {n}, Word.word n -> Word.word (b + b); (* main hash function *) + EdDSA_B_not_identity : B <> Ezero; - c : nat; (* cofactor E = 2^c *) - c_valid : c = 2 \/ c = 3; + 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. - n : nat; (* secret keys are (n+1) bits *) - n_ge_c : n >= c; - n_le_b : n <= b; + Context `{prm:EdDSA}. - B : E.point; - B_not_identity : B <> E.zero; + 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). - 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 Arguments H {n} _. + Local Notation wfirstn n w := (@WordUtil.wfirstn n _ w _) (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 *) + 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/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 377fb9592..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] ] - => let G' := context G[Let_In x (fun y => f (unRep y))] in change G'; 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. diff --git a/src/Specific/GF25519.v b/src/Specific/GF25519.v index 8ee9b25d8..6d7e2c38c 100644 --- a/src/Specific/GF25519.v +++ b/src/Specific/GF25519.v @@ -7,9 +7,9 @@ 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. +Require Import Crypto.Util.Notations. Local Open Scope Z. (* BEGIN PseudoMersenneBaseParams instance construction. *) @@ -57,7 +57,20 @@ Proof. pose proof (carry_mul_opt_rep k_ c_ (eq_refl k_) c_subst _ _ _ _ Hf Hg) as Hfg. compute_formula. exact Hfg. -Time Defined. +(*Time*) Defined. + +(* Uncomment this to see a pretty-printed mulmod +Local Transparent Let_In. +Infix "<<" := Z.shiftr. +Infix "&" := Z.land. +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. @@ -110,104 +123,9 @@ Defined. (* Set Printing Depth 1000. Local Transparent Let_In. -Infix "<<" := Z.shiftr (at level 50). -Infix "&" := Z.land (at level 50). +Infix "<<" := Z.shiftr. +Infix "&" := Z.land. 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). *) - -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. -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; apply f_equal; reflexivity]]; - 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. -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; apply f_equal; reflexivity]]; - 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; apply f_equal; reflexivity]]; - destruct E as [? r]; cbv [proj1_sig]. - cbv [rep ModularBaseSystem.rep PseudoMersenneBase modulus] in r; edestruct r; eauto. -Qed. diff --git a/src/Tactics/Nsatz.v b/src/Tactics/Nsatz.v new file mode 100644 index 000000000..84d472e54 --- /dev/null +++ b/src/Tactics/Nsatz.v @@ -0,0 +1,155 @@ +(*** 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. + +(** As per https://coq.inria.fr/bugs/show_bug.cgi?id=4851, [nsatz] + cannot handle duplicate hypotheses. So we clear them. *) +Ltac nsatz_clear_duplicates_for_bug_4851 domain := + lazymatch type of domain with + | @Integral_domain.Integral_domain _ _ _ _ _ _ _ ?eq _ _ _ => + repeat match goal with + | [ H : eq ?x ?y, H' : eq ?x ?y |- _ ] => clear 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_clear_duplicates_for_bug_4851 domain; + 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. + +(** If the goal is of the form [?x <> ?y] and assuming [?x = ?y] + contradicts any hypothesis of the form [?x' <> ?y'], we turn this + problem about inequalities into one about equalities and give it + to [nsatz]. *) +Ltac nsatz_contradict_single_hypothesis domain := + lazymatch type of domain with + | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring => + unfold not in *; + match goal with + | [ H : eq _ _ -> False |- eq _ _ -> False ] + => intro; apply H; nsatz + | [ H : eq _ _ -> False |- False ] + => apply H; nsatz + end + end. + +Ltac nsatz_contradict := + let domain := nsatz_guess_domain in + nsatz_contradict_single_hypothesis domain + || (unfold not; + intros; + 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/Util/Decidable.v b/src/Util/Decidable.v new file mode 100644 index 000000000..9ab05699a --- /dev/null +++ b/src/Util/Decidable.v @@ -0,0 +1,64 @@ +(** Typeclass for decidable propositions *) + +Require Import Coq.Logic.Eqdep_dec. + +Local Open Scope type_scope. + +Class Decidable (P : Prop) := dec : {P} + {~P}. + +Notation DecidableRel R := (forall x y, Decidable (R x y)). + +Ltac destruct_decidable_step := + match goal with + | [ H : Decidable _ |- _ ] => destruct H + end. +Ltac destruct_decidable := repeat destruct_decidable_step. + +Local Ltac pre_decide := + repeat (intros + || destruct_decidable + || subst + || split + || unfold Decidable in * + || hnf ). + +Local Ltac solve_decidable_transparent_with tac := + pre_decide; + try solve [ left; abstract tac + | right; abstract tac + | decide equality; eauto with nocore ]. + +Local Ltac solve_decidable_transparent := solve_decidable_transparent_with firstorder. + +Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances. + +Global Instance dec_True : Decidable True | 10 := left I. +Global Instance dec_False : Decidable False | 10 := right (fun x => x). +Global Instance dec_or {A B} `{Decidable A, Decidable B} : Decidable (A \/ B) | 10. exact _. Defined. +Global Instance dec_and {A B} `{Decidable A, Decidable B} : Decidable (A /\ B) | 10. exact _. Defined. +Global Instance dec_impl {A B} `{Decidable (B \/ ~A)} : Decidable (A -> B) | 10. exact _. Defined. +Global Instance dec_impl_simple {A B} `{Decidable A, Decidable B} : Decidable (A -> B) | 10. exact _. Defined. +Global Instance dec_iff {A B} `{Decidable A, Decidable B} : Decidable (A <-> B) | 10. exact _. Defined. +Lemma dec_not {A} `{Decidable A} : Decidable (~A). +Proof. solve_decidable_transparent. Defined. +(** Disallow infinite loops of dec_not *) +Hint Extern 0 (Decidable (~?A)) => apply (@dec_not A) : typeclass_instances. + +Global Instance dec_eq_unit : DecidableRel (@eq unit) | 10. exact _. Defined. +Global Instance dec_eq_bool : DecidableRel (@eq bool) | 10. exact _. Defined. +Global Instance dec_eq_Empty_set : DecidableRel (@eq Empty_set) | 10. exact _. Defined. +Global Instance dec_eq_nat : DecidableRel (@eq nat) | 10. exact _. Defined. +Global Instance dec_eq_prod {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A * B)) | 10. exact _. Defined. +Global Instance dec_eq_sum {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A + B)) | 10. exact _. Defined. + +Lemma Decidable_respects_iff A B (H : A <-> B) : (Decidable A -> Decidable B) * (Decidable B -> Decidable A). +Proof. solve_decidable_transparent. Defined. + +Lemma Decidable_iff_to_impl A B (H : A <-> B) : Decidable A -> Decidable B. +Proof. solve_decidable_transparent. Defined. + +Lemma Decidable_iff_to_flip_impl A B (H : A <-> B) : Decidable B -> Decidable A. +Proof. solve_decidable_transparent. Defined. + +(** For dubious compatibility with [eauto using]. *) +Hint Extern 2 (Decidable _) => progress unfold Decidable : typeclass_instances core. diff --git a/src/Util/ListUtil.v b/src/Util/ListUtil.v index 9a9ce9a06..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). @@ -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 diff --git a/src/Util/Notations.v b/src/Util/Notations.v new file mode 100644 index 000000000..c3f776766 --- /dev/null +++ b/src/Util/Notations.v @@ -0,0 +1,23 @@ +(** * Reserved Notations *) + +(** Putting them all together in one file prevents conflicts. Coq's + parser (camlpX) is really bad at conflicting notation levels and + is sometimes really bad at backtracking, too. Not having level + declarations in other files makes it harder for us to confuse + Coq's parser. *) + +Reserved Infix "=?" (at level 70, no associativity). +Reserved Infix "!=?" (at level 70, no associativity). +Reserved Infix "?=" (at level 70, no associativity). +Reserved Infix "?<" (at level 70, no associativity). +Reserved Infix ".+" (at level 50). +Reserved Infix ".*" (at level 50). +Reserved Notation "x ^ 2" (at level 30, format "x ^ 2"). +Reserved Notation "x ^ 3" (at level 30, format "x ^ 3"). +Reserved Infix "mod" (at level 40, no associativity). +Reserved Notation "'canonical' 'encoding' 'of' T 'as' B" (at level 50). +Reserved Infix "<<" (at level 50). +Reserved Infix "&" (at level 50). +Reserved Infix "<<" (at level 50). +Reserved Infix "&" (at level 50). +Reserved Infix "~=" (at level 70). diff --git a/src/Util/Sum.v b/src/Util/Sum.v new file mode 100644 index 000000000..2f03639b2 --- /dev/null +++ b/src/Util/Sum.v @@ -0,0 +1,18 @@ +Require Import Coq.Classes.Morphisms. +Require Import Relation_Definitions. + +Definition sumwise {A B} (RA:relation A) (RB : relation B) : relation (A + B) + := fun x y => match x, y with + | inl x', inl y' => RA x' y' + | inr x', inr y' => RB x' y' + | _, _ => False + end. + +Global Instance Equivalence_sumwise {A B} {RA:relation A} {RB:relation B} + {RA_equiv:Equivalence RA} {RB_equiv:Equivalence RB} + : Equivalence (sumwise RA RB). +Proof. + split; repeat intros [?|?]; simpl; trivial; destruct RA_equiv, RB_equiv; try tauto; eauto. +Qed. + +Arguments sumwise {A B} _ _ _ _. diff --git a/src/Util/Tactics.v b/src/Util/Tactics.v index 08ebfe13e..e8876fee2 100644 --- a/src/Util/Tactics.v +++ b/src/Util/Tactics.v @@ -1,5 +1,19 @@ (** * Generic Tactics *) +(** Test if a tactic succeeds, but always roll-back the results *) +Tactic Notation "test" tactic3(tac) := + try (first [ tac | fail 2 tac "does not succeed" ]; fail 0 tac "succeeds"; [](* test for [t] solved all goals *)). + +(** [not tac] is equivalent to [fail tac "succeeds"] if [tac] succeeds, and is equivalent to [idtac] if [tac] fails *) +Tactic Notation "not" tactic3(tac) := try ((test tac); fail 1 tac "succeeds"). + +(** find the head of the given expression *) +Ltac head expr := + match expr with + | ?f _ => head f + | _ => expr + end. + (* [pose proof defn], but only if no hypothesis of the same type exists. most useful for proofs of a proposition *) Tactic Notation "unique" "pose" "proof" constr(defn) := @@ -23,3 +37,77 @@ Tactic Notation "unique" "assert" constr(T) "by" tactic3(tac) := | [ H : T |- _ ] => fail 1 | _ => assert T by tac end. + +(** destruct discriminees of [match]es in the goal *) +(* Prioritize breaking apart things in the context, then things which + don't need equations, then simple matches (which can be displayed + as [if]s), and finally matches in general. *) +Ltac break_match_step only_when := + match goal with + | [ |- appcontext[match ?e with _ => _ end] ] + => only_when e; is_var e; destruct e + | [ |- appcontext[match ?e with _ => _ end] ] + => only_when e; + match type of e with + | sumbool _ _ => destruct e + end + | [ |- appcontext[if ?e then _ else _] ] + => only_when e; destruct e eqn:? + | [ |- appcontext[match ?e with _ => _ end] ] + => only_when e; destruct e eqn:? + end. +Ltac break_match := repeat break_match_step ltac:(fun _ => idtac). +Ltac break_match_when_head_step T := + break_match_step + ltac:(fun e => let T' := type of e in + let T' := head T' in + constr_eq T T'). +Ltac break_match_when_head T := repeat break_match_when_head_step T. + +Ltac free_in x y := + idtac; + match y with + | appcontext[x] => fail 1 x "appears in" y + | _ => idtac + end. + +Ltac setoid_subst'' R x := + is_var x; + match goal with + | [ H : R x ?y |- _ ] + => free_in x y; rewrite ?H in *; clear x H + | [ H : R ?y x |- _ ] + => free_in x y; rewrite <- ?H in *; clear x H + end. + +Ltac setoid_subst' x := + is_var x; + match goal with + | [ H : ?R x _ |- _ ] => setoid_subst'' R x + | [ H : ?R _ x |- _ ] => setoid_subst'' R x + end. + +Ltac setoid_subst_rel' R := + idtac; + match goal with + | [ H : R ?x _ |- _ ] => setoid_subst'' R x + | [ H : R _ ?x |- _ ] => setoid_subst'' R x + end. + +Ltac setoid_subst_rel R := repeat setoid_subst_rel' R. + +Ltac setoid_subst_all := + repeat match goal with + | [ H : ?R ?x ?y |- _ ] => is_var x; setoid_subst'' R x + | [ H : ?R ?x ?y |- _ ] => is_var y; setoid_subst'' R y + end. + +Tactic Notation "setoid_subst" ident(x) := setoid_subst' x. +Tactic Notation "setoid_subst" := setoid_subst_all. + +Ltac destruct_trivial_step := + match goal with + | [ H : unit |- _ ] => clear H || destruct H + | [ H : True |- _ ] => clear H || destruct H + end. +Ltac destruct_trivial := repeat destruct_trivial_step. 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/Unit.v b/src/Util/Unit.v new file mode 100644 index 000000000..cf5c4f669 --- /dev/null +++ b/src/Util/Unit.v @@ -0,0 +1,8 @@ +Require Import Coq.Classes.Morphisms. +Require Import Relation_Definitions. + +(* an equivalence for a relation on trivial things, like [unit] *) +Global Instance Equivalence_trivial {A} : Equivalence (fun _ _ : A => True). +Proof. + repeat constructor. +Qed. |