Commit 78b09e76 authored by benoit's avatar benoit
Browse files

fix

parent 510cad59
......@@ -17,6 +17,7 @@
.depend
.loadpath
_CoqProject
!packages/**/_CoqProject
*.cache
*~
*#
......
DIST=coq-verif-tweetnacl
# NO_COLOR="\033[0m"
# RED = "\033[38;5;009m"
# GREEN = "\033[38;5;010m"
# YELLOW = "\033[38;5;011m"
# ORANGE = "\033[38;5;214m"
# LIGHTPURPLE = "\033[38;5;177m"
# PURPLE = "\033[38;5;135m"
# CYAN = "\033[38;5;014m"
# LIGHTGRAY = "\033[38;5;252m"
# DARKGRAY = "\033[38;5;242m"
# BRIGHTRED = "\033[91m"
# BOLD = "\033[1m"
#
# all: coq-tweetnacl-spec coq-tweetnacl-vst
include coq.mk
.PHONY: clean
clean: clean-spec clean-vst clean-dist
# build paper
.PHONY: paper
paper:
@cd paper && $(MAKE)
clean-paper:
cd paper && $(MAKE) clean
# generate artefact
$(DIST):
@echo $(BOLD)$(ORANGE)"Creating $(DIST)"$(NO_COLOR)$(DARKGRAY)
mkdir $(DIST)
$(DIST)/specs_map.pdf:
@echo $(BOLD)$(YELLOW)"Building map for specs"$(NO_COLOR)$(DARKGRAY)
cd paper && $(MAKE) specs_map.pdf
mv specs_map.pdf $(DIST)/specs_map.pdf
dist: clean-dist $(DIST) $(DIST)/specs_map.pdf
@echo $(BOLD)$(YELLOW)"Preparing $(DIST)"$(NO_COLOR)$(DARKGRAY)
cp -r proofs $(DIST)
cd $(DIST)/proofs/spec && $(MAKE) clean
cd $(DIST)/proofs/vst && $(MAKE) clean
mkdir $(DIST)/packages
cp -r packages/coq-compcert $(DIST)/packages/
cp -r packages/coq-reciprocity $(DIST)/packages/
cp -r packages/coq-ssr-elliptic-curves $(DIST)/packages/
cp -r packages/coq-vst $(DIST)/packages/
cp repo $(DIST)/
cp version $(DIST)/
cp README.md $(DIST)/
cp coq.mk $(DIST)/Makefile
cp opam $(DIST)/
@echo $(BOLD)$(LIGHTPURPLE)"Building $(DIST).tar.gz"$(NO_COLOR)$(DARKGRAY)
tar -czvf $(DIST).tar.gz $(DIST)
@echo $(BOLD)$(GREEN)"Done."$(NO_COLOR)
clean-dist:
@echo $(BOLD)$(YELLOW)"removing $(DIST)"$(NO_COLOR)$(DARKGRAY)
-rm -r $(DIST)
-rm $(DIST).tar.gz
@echo $(BOLD)$(GREEN)"Done."$(NO_COLOR)
BigN/NMake_gen.v
*.d
*.o
*.cmi
*.cmx
*.cmxs
*.vo
*.glob
*.aux
Makefile.coq
Makefile.coq.conf
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(** * Efficient arbitrary large natural numbers in base 2^31 *)
(** Initial Author: Arnaud Spiwack *)
Require Export Int31.
Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake
NProperties GenericMinMax.
(** The following [BigN] module regroups both the operations and
all the abstract properties:
- [NMake.Make Int31Cyclic] provides the operations and basic specs
w.r.t. ZArith
- [NTypeIsNAxioms] shows (mainly) that these operations implement
the interface [NAxioms]
- [NProp] adds all generic properties derived from [NAxioms]
- [MinMax*Properties] provides properties of [min] and [max].
*)
Delimit Scope bigN_scope with bigN.
Module BigN <: NType <: OrderedTypeFull <: TotalOrder :=
NMake.Make Int31Cyclic
<+ NTypeIsNAxioms
<+ NBasicProp [no inline] <+ NExtraProp [no inline]
<+ HasEqBool2Dec [no inline]
<+ MinMaxLogicalProperties [no inline]
<+ MinMaxDecProperties [no inline].
(** Notations about [BigN] *)
Local Open Scope bigN_scope.
Notation bigN := BigN.t.
Bind Scope bigN_scope with bigN BigN.t BigN.t'.
Arguments BigN.N0 _%int31.
Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *)
Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *)
Local Notation "2" := BigN.two : bigN_scope. (* temporary notation *)
Infix "+" := BigN.add : bigN_scope.
Infix "-" := BigN.sub : bigN_scope.
Infix "*" := BigN.mul : bigN_scope.
Infix "/" := BigN.div : bigN_scope.
Infix "^" := BigN.pow : bigN_scope.
Infix "?=" := BigN.compare : bigN_scope.
Infix "=?" := BigN.eqb (at level 70, no associativity) : bigN_scope.
Infix "<=?" := BigN.leb (at level 70, no associativity) : bigN_scope.
Infix "<?" := BigN.ltb (at level 70, no associativity) : bigN_scope.
Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope.
Notation "x != y" := (~x==y) (at level 70, no associativity) : bigN_scope.
Infix "<" := BigN.lt : bigN_scope.
Infix "<=" := BigN.le : bigN_scope.
Notation "x > y" := (y < x) (only parsing) : bigN_scope.
Notation "x >= y" := (y <= x) (only parsing) : bigN_scope.
Notation "x < y < z" := (x<y /\ y<z) : bigN_scope.
Notation "x < y <= z" := (x<y /\ y<=z) : bigN_scope.
Notation "x <= y < z" := (x<=y /\ y<z) : bigN_scope.
Notation "x <= y <= z" := (x<=y /\ y<=z) : bigN_scope.
Notation "[ i ]" := (BigN.to_Z i) : bigN_scope.
Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope.
(** Example of reasoning about [BigN] *)
Theorem succ_pred: forall q : bigN,
0 < q -> BigN.succ (BigN.pred q) == q.
Proof.
intros; apply BigN.succ_pred.
intro H'; rewrite H' in H; discriminate.
Qed.
(** [BigN] is a semi-ring *)
Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq.
Proof.
constructor.
exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc.
exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm.
exact BigN.mul_assoc. exact BigN.mul_add_distr_r.
Qed.
Lemma BigNeqb_correct : forall x y, (x =? y) = true -> x==y.
Proof. now apply BigN.eqb_eq. Qed.
Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow.
Proof.
constructor.
intros. red. rewrite BigN.spec_pow, BigN.spec_of_N.
rewrite Zpower_theory.(rpow_pow_N).
destruct n; simpl. reflexivity.
induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto.
Qed.
Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _)
(fun a b => if b =? 0 then (0,a) else BigN.div_eucl a b).
Proof.
constructor. unfold id. intros a b.
BigN.zify.
case Z.eqb_spec.
BigN.zify. auto with zarith.
intros NEQ.
generalize (BigN.spec_div_eucl a b).
generalize (Z_div_mod_full [a] [b] NEQ).
destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r').
intros (EQ,_). injection 1 as EQr EQq.
BigN.zify. rewrite EQr, EQq; auto.
Qed.
(** Detection of constants *)
Ltac isStaticWordCst t :=
match t with
| W0 => constr:(true)
| WW ?t1 ?t2 =>
match isStaticWordCst t1 with
| false => constr:(false)
| true => isStaticWordCst t2
end
| _ => isInt31cst t
end.
Ltac isBigNcst t :=
match t with
| BigN.N0 ?t => isStaticWordCst t
| BigN.N1 ?t => isStaticWordCst t
| BigN.N2 ?t => isStaticWordCst t
| BigN.N3 ?t => isStaticWordCst t
| BigN.N4 ?t => isStaticWordCst t
| BigN.N5 ?t => isStaticWordCst t
| BigN.N6 ?t => isStaticWordCst t
| BigN.Nn ?n ?t => match isnatcst n with
| true => isStaticWordCst t
| false => constr:(false)
end
| BigN.zero => constr:(true)
| BigN.one => constr:(true)
| BigN.two => constr:(true)
| _ => constr:(false)
end.
Ltac BigNcst t :=
match isBigNcst t with
| true => constr:(t)
| false => constr:(NotConstant)
end.
Ltac BigN_to_N t :=
match isBigNcst t with
| true => eval vm_compute in (BigN.to_N t)
| false => constr:(NotConstant)
end.
Ltac Ncst t :=
match isNcst t with
| true => constr:(t)
| false => constr:(NotConstant)
end.
(** Registration for the "ring" tactic *)
Add Ring BigNr : BigNring
(decidable BigNeqb_correct,
constants [BigNcst],
power_tac BigNpower [BigN_to_N],
div BigNdiv).
Section TestRing.
Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
intros. ring_simplify. reflexivity.
Qed.
End TestRing.
(** We benefit also from an "order" tactic *)
Ltac bigN_order := BigN.order.
Section TestOrder.
Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
Proof. bigN_order. Qed.
End TestOrder.
(** We can use at least a bit of (r)omega by translating to [Z]. *)
Section TestOmega.
Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
Proof. intros x y. BigN.zify. omega. Qed.
End TestOmega.
(** Todo: micromega *)
This diff is collapsed.
This diff is collapsed.
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
Require Import ZArith Ndigits.
Require Import BigNumPrelude.
Require Import Max.
Require Import DoubleType.
Require Import DoubleBase.
Require Import CyclicAxioms.
Require Import DoubleCyclic.
Arguments mk_zn2z_ops [t] ops.
Arguments mk_zn2z_ops_karatsuba [t] ops.
Arguments mk_zn2z_specs [t ops] specs.
Arguments mk_zn2z_specs_karatsuba [t ops] specs.
Arguments ZnZ.digits [t] Ops.
Arguments ZnZ.zdigits [t] Ops.
Lemma Pshiftl_nat_Zpower : forall n p,
Zpos (Pos.shiftl_nat p n) = Zpos p * 2 ^ Z.of_nat n.
Proof.
intros.
rewrite Z.mul_comm.
induction n. simpl; auto.
transitivity (2 * (2 ^ Z.of_nat n * Zpos p)).
rewrite <- IHn. auto.
rewrite Z.mul_assoc.
rewrite Nat2Z.inj_succ.
rewrite <- Z.pow_succ_r; auto with zarith.
Qed.
(* To compute the necessary height *)
Fixpoint plength (p: positive) : positive :=
match p with
xH => xH
| xO p1 => Pos.succ (plength p1)
| xI p1 => Pos.succ (plength p1)
end.
Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z).
intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z.
rewrite Zpower_exp; auto with zarith.
rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith.
intros p; elim p; simpl plength; auto.
intros p1 Hp1; rewrite F; repeat rewrite Pos2Z.inj_xI.
assert (tmp: (forall p, 2 * p = p + p)%Z);
try repeat rewrite tmp; auto with zarith.
intros p1 Hp1; rewrite F; rewrite (Pos2Z.inj_xO p1).
assert (tmp: (forall p, 2 * p = p + p)%Z);
try repeat rewrite tmp; auto with zarith.
rewrite Z.pow_1_r; auto with zarith.
Qed.
Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))%Z.
intros p; case (Pos.succ_pred_or p); intros H1.
subst; simpl plength.
rewrite Z.pow_1_r; auto with zarith.
pattern p at 1; rewrite <- H1.
rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith.
generalize (plength_correct (Pos.pred p)); auto with zarith.
Qed.
Definition Pdiv p q :=
match Z.div (Zpos p) (Zpos q) with
Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with
Z0 => q1
| _ => (Pos.succ q1)
end
| _ => xH
end.
Theorem Pdiv_le: forall p q,
Zpos p <= Zpos q * Zpos (Pdiv p q).
intros p q.
unfold Pdiv.
assert (H1: Zpos q > 0); auto with zarith.
assert (H1b: Zpos p >= 0); auto with zarith.
generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b).
generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Z.div.
intros HH _; rewrite HH; rewrite Z.mul_0_r; rewrite Z.mul_1_r; simpl.
case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
intros q1 H2.
replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2;
case Z.modulo.
intros HH _; rewrite HH; auto with zarith.
intros r1 HH (_,HH1); rewrite HH; rewrite Pos2Z.inj_succ.
unfold Z.succ; rewrite Z.mul_add_distr_l; auto with zarith.
intros r1 _ (HH,_); case HH; auto.
intros q1 HH; rewrite HH.
unfold Z.ge; simpl Z.compare; intros HH1; case HH1; auto.
Qed.
Definition is_one p := match p with xH => true | _ => false end.
Theorem is_one_one: forall p, is_one p = true -> p = xH.
intros p; case p; auto; intros p1 H1; discriminate H1.
Qed.
Definition get_height digits p :=
let r := Pdiv p digits in
if is_one r then xH else Pos.succ (plength (Pos.pred r)).
Theorem get_height_correct:
forall digits N,
Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)).
intros digits N.
unfold get_height.
assert (H1 := Pdiv_le N digits).
case_eq (is_one (Pdiv N digits)); intros H2.
rewrite (is_one_one _ H2) in H1.
rewrite Z.mul_1_r in H1.
change (2^(1-1))%Z with 1; rewrite Z.mul_1_r; auto.
clear H2.
apply Z.le_trans with (1 := H1).
apply Z.mul_le_mono_nonneg_l; auto with zarith.
rewrite Pos2Z.inj_succ; unfold Z.succ.
rewrite Z.add_comm; rewrite Z.add_simpl_l.
apply plength_pred_correct.
Qed.
Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
fix zn2z_word_comm 2.
intros w n; case n.
reflexivity.
intros n0;simpl.
case (zn2z_word_comm w n0).
reflexivity.
Defined.
Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) :=
match n return forall w:Type, zn2z w -> word w (S n) with
| O => fun w x => x
| S m =>
let aux := extend m in
fun w x => WW W0 (aux w x)
end.
Section ExtendMax.
Open Scope nat_scope.
Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat :=
match n return (n + S m = S (n + m))%nat with
| 0 => eq_refl (S m)
| S n1 =>
let v := S (S n1 + m) in
eq_ind_r (fun n => S n = v) (eq_refl v) (plusnS n1 m)
end.
Fixpoint plusn0 n : n + 0 = n :=
match n return (n + 0 = n) with
| 0 => eq_refl 0
| S n1 =>
let v := S n1 in
eq_ind_r (fun n : nat => S n = v) (eq_refl v) (plusn0 n1)
end.
Fixpoint diff (m n: nat) {struct m}: nat * nat :=
match m, n with
O, n => (O, n)
| m, O => (m, O)
| S m1, S n1 => diff m1 n1
end.
Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
match m return fst (diff m n) + n = max m n with
| 0 =>
match n return (n = max 0 n) with
| 0 => eq_refl _
| S n0 => eq_refl _
end
| S m1 =>
match n return (fst (diff (S m1) n) + n = max (S m1) n)
with
| 0 => plusn0 _
| S n1 =>
let v := fst (diff m1 n1) + n1 in
let v1 := fst (diff m1 n1) + S n1 in
eq_ind v (fun n => v1 = S n)
(eq_ind v1 (fun n => v1 = n) (eq_refl v1) (S v) (plusnS _ _))
_ (diff_l _ _)
end
end.
Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
match m return (snd (diff m n) + m = max m n) with
| 0 =>
match n return (snd (diff 0 n) + 0 = max 0 n) with
| 0 => eq_refl _
| S _ => plusn0 _
end
| S m =>
match n return (snd (diff (S m) n) + S m = max (S m) n) with
| 0 => eq_refl (snd (diff (S m) 0) + S m)
| S n1 =>
let v := S (max m n1) in
eq_ind_r (fun n => n = v)
(eq_ind_r (fun n => S n = v)
(eq_refl v) (diff_r _ _)) (plusnS _ _)
end
end.
Variable w: Type.
Definition castm (m n: nat) (H: m = n) (x: word w (S m)):
(word w (S n)) :=
match H in (_ = y) return (word w (S y)) with
| eq_refl => x
end.
Variable m: nat.
Variable v: (word w (S m)).
Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) :=
match n return (word w (S (n + m))) with
| O => v
| S n1 => WW W0 (extend_tr n1)
end.
End ExtendMax.
Arguments extend_tr [w m] v n.
Arguments castm [w m n] H x.
Section Reduce.
Variable w : Type.
Variable nT : Type.
Variable N0 : nT.
Variable eq0 : w -> bool.
Variable reduce_n : w -> nT.
Variable zn2z_to_Nt : zn2z w -> nT.
Definition reduce_n1 (x:zn2z w) :=
match x with
| W0 => N0
| WW xh xl =>
if eq0 xh then reduce_n xl
else zn2z_to_Nt x
end.
End Reduce.
Section ReduceRec.
Variable w : Type.
Variable nT : Type.
Variable N0 : nT.
Variable reduce_1n : zn2z w -> nT.
Variable c : forall n, word w (S n) -> nT.
Fixpoint reduce_n (n:nat) : word w (S n) -> nT :=
match n return word w (S n) -> nT with
| O => reduce_1n
| S m => fun x =>
match x with
| W0 => N0
| WW xh xl =>
match xh with
| W0 => @reduce_n m xl
| _ => @c (S m) x
end
end
end.
End ReduceRec.
Section CompareRec.