From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Structure.Monoidal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Reserved Infix "⟿" (at level 90, right associativity).

Class Enriched (K : Category) `{@Monoidal K} := {
eobj : Type;

ehom : eobj -> eobj -> K where "a ⟿ b" := (ehom a b);

eid {x} : I ~{K}~> (x ⟿ x);
ecompose {x y z} : (y ⟿ z) ⨂ (x ⟿ y) ~{K}~> (x ⟿ z);

eid_left  {x y} :
ecompose ∘ eid ⨂ id << I ⨂ (x ⟿ y) ~~> (x ⟿ y) >> unit_left;
eid_right {x y} :
ecompose ∘ id ⨂ eid << (x ⟿ y) ⨂ I ~~> (x ⟿ y) >> unit_right;

ecompose_assoc {x y z w} :
ecompose ∘ ecompose ⨂ id
<< ((z ⟿ w) ⨂ (y ⟿ z)) ⨂ (x ⟿ y) ~~> (x ⟿ w) >>
ecompose ∘ id ⨂ ecompose ∘ tensor_assoc
}.

Infix "⟿" := ehom (at level 90, right associativity).

Coercion eobj : Enriched >-> Sortclass.

Class EnrichedFunctor
(K : Category) `{@Monoidal K}
(C : Enriched K) (D : Enriched K) := {
efobj : C -> D;
efmap {x y} : (x ⟿ y) ~{K}~> (efobj x ⟿ efobj y);

efmap_id : ∀ x,
efmap ∘ eid << I ~~> (efobj x ⟿ efobj x) >> eid;
efmap_comp : ∀ x y z,
ecompose ∘ efmap ⨂ efmap
<< (y ⟿ z) ⨂ (x ⟿ y) ~~> (efobj x ⟿ efobj z) >>
efmap ∘ ecompose
}.

Require Import Category.Instance.Sets.

Theorem Category_is_Enriched_over_Set : Enriched Sets ↔ Category.
Proof. hammer_hook "Enriched" "Enriched.Category_is_Enriched_over_Set".
split; intros.
- unshelve refine
{| obj     := eobj
; hom     := @ehom _ _ X
; homset  := @ehom _ _ X
; id      := fun x => @eid _ _ X x tt
; compose := fun x y z f g => @ecompose _ _ X x y z (f, g) |}.
+ intros.
proper.
destruct X.
simpl in *.
destruct (ecompose0 x y z).
simpl in *.
now apply proper_morphism; simpl; auto.
+ intros.
destruct X.
simpl in *.
now sapply (eid_left0 x y (tt, f)).
+ intros.
destruct X.
simpl in *.
now sapply (eid_right0 x y (f, tt)).
+ intros.
destruct X.
simpl in *.
symmetry.
now sapply (ecompose_assoc0 x y z w ((f, g), h)).
+ intros.
destruct X.
simpl in *.
now sapply (ecompose_assoc0 x y z w ((f, g), h)).
- unshelve refine
(@Build_Enriched Sets Sets_Product_Monoidal
obj
(fun x y : X => {| carrier := x ~> y |})
(fun x => {| morphism := fun _ => id[x] |})
(fun x y z => {| morphism := fun p => fst p ∘ snd p |})
_ _ _).
+ now apply homset.
+ now proper.
+ proper; simpl.
apply compose_respects;
now destruct X0.
+ now simpl; intros; cat.
+ now simpl; intros; cat.
+ now simpl; intros; cat.
Defined.

Theorem Functor_is_Enriched_over_Set (C D : Category) :
EnrichedFunctor
Sets
(snd Category_is_Enriched_over_Set C)
(snd Category_is_Enriched_over_Set D)
↔ (C ⟶ D).
Proof. hammer_hook "Enriched" "Enriched.Functor_is_Enriched_over_Set".
split; intros.
- destruct X; simpl in *.
construct.
+ now apply efobj0.
+ now apply efmap0.
+ proper.
now apply efmap0.
+ now apply efmap_id0.
+ simpl in *.
now srewrite (efmap_comp0 x y z (f, g)).
- destruct X; simpl in *.
construct.
+ now apply fobj.
+ construct.
* now apply fmap.
* proper.
now apply fmap_respects.
+ now apply fmap_id.
+ simpl.
symmetry.
now apply fmap_comp.
Defined.


Require Import Rel.Definitions Rel.BasicFacts.
Require Import Util.Subset.
Require Import Lang.BindingsFacts.
Set Implicit Arguments.

Section section_compat_val_fun.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (𝔽 : F).
Context (S T : ty EV HV ∅).
Context (𝓔 : eff EV HV ∅).
Context (t₁ t₂ : tm EV HV (inc V) ∅).

Hint Resolve subset_trans postfix_is_subset.

Lemma compat_val_fun n :
n ⊨ ⟦ Ξ P (env_ext Γ S) ⊢ t₁ ≼ˡᵒᵍ t₂ : T # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (val_fun t₁) ≼ˡᵒᵍᵥ (val_fun t₂) : ty_fun S T 𝓔 ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
ielim_prop Hξ ; destruct Hξ as [Hξ₁ Hξ₂].
ielim_prop cl_ρ₁ρ₂.

simpl.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro u₁ ; iintro u₂ ; iintro Hu.
ielim_prop Hξ₁' ; ielim_prop Hξ₂'.

ispecialize Ht ξ₁' ; ispecialize Ht ξ₂'.
ispecialize Ht δ₁ ; ispecialize Ht δ₂ ; ispecialize Ht δ.
ispecialize Ht ρ₁ ; ispecialize Ht ρ₂ ; ispecialize Ht ρ.
ispecialize Ht (env_ext γ₁ u₁) ; ispecialize Ht (env_ext γ₂ u₂).
ispecialize Ht.
{ clear - Hξ₁ Hξ₂ Hξ₁' Hξ₂'.
  iintro_prop ; split ; eauto.
}
ispecialize Ht.
{ clear - cl_δ Hξ₁' Hξ₂'.
  repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
  ielim_prop cl_δ ; destruct cl_δ ; split ; eauto.
}
ispecialize Ht.
{ clear - cl_ρ₁ρ₂ Hξ₁' Hξ₂'.
  iintro_prop ; eapply closed_ρ_monotone ; eauto.
}
ispecialize Ht.
{ clear - Hρ Hξ₁' Hξ₂'.
  eapply 𝑷_monotone ; eauto.
}
ispecialize Ht.
{ clear - Hγ Hu Hξ₁' Hξ₂'.
  iintro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  iespecialize Hγ.
  eapply 𝓥_monotone ; eassumption.
}
clear - Ht.

eapply 𝓣_step_r ; [ apply step_app | ].
eapply 𝓣_step_l ; [ apply step_app | ].
iintro_later.
repeat erewrite V_bind_bind_tm.
rewrite HV_bind_tm_eq with
  (f := V_shift_hd ∘ (V_open_hd ∘ ρ₁))
  (g := V_open_hd ∘ ρ₁).
rewrite HV_bind_tm_eq with
  (f := V_shift_hd ∘ (V_open_hd ∘ ρ₂))
  (g := V_open_hd ∘ ρ₂).
exact Ht.

{ intro ; unfold compose ; erewrite V_map_map_hd ; crush. }
{ intro ; unfold compose ; erewrite V_map_map_hd ; crush. }
{ intro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  erewrite V_bind_map_val, V_bind_val_id, V_map_val_id ; crush.
}
{ intro x ; destruct x as [ | x ] ; simpl ; [ crush | ].
  erewrite V_bind_map_val, V_bind_val_id, V_map_val_id ; crush.
}

Qed.

End section_compat_val_fun.


From Coq Require Import ZArith .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition bi : Set := N * N * N * N * N.

Definition bi_list (X : bi) :=
  let '(x0, x1, x2, x3, x4) := X in
  [:: x0; x1; x2; x3; x4].

Definition bi_limbs (X : bi) :=
  let '(x0, x1, x2, x3, x4) := X in
  radix51 [:: zVar x0; zVar x1; zVar x2; zVar x3; zVar x4].

Definition fe25519_add (X Y R : bi) : program :=
let '(x0, x1, x2, x3, x4) := X in
let '(y0, y1, y2, y3, y4) := Y in
let '(r0, r1, r2, r3, r4) := R in
[::
      (* r0 = x0 *)
zAssign r0 (zVar x0);
      (* r1 = x1 *)
zAssign r1 (zVar x1);
      (* r2 = x2 *)
zAssign r2 (zVar x2);
      (* r3 = x3 *)
zAssign r3 (zVar x3);
      (* r4 = x4 *)
zAssign r4 (zVar x4);
      (* r0 += y0 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar y0));
      (* r1 += y1 *)
zAssign r1 (zBinop zAdd (zVar r1) (zVar y1));
      (* r2 += y2 *)
zAssign r2 (zBinop zAdd (zVar r2) (zVar y2));
      (* r3 += y3 *)
zAssign r3 (zBinop zAdd (zVar r3) (zVar y3));
      (* r4 += y4 *)
zAssign r4 (zBinop zAdd (zVar r4) (zVar y4))
      (*  *)
] .

Definition fe25519_sub (X Y R : bi) : program :=
let '(x0, x1, x2, x3, x4) := X in
let '(y0, y1, y2, y3, y4) := Y in
let '(r0, r1, r2, r3, r4) := R in
let crypto_sign_ed25519_amd64_51_2P0 :=
                       4503599627370458%Z in (* 0xFFFFFFFFFFFDA from consts *)
let crypto_sign_ed25519_amd64_51_2P1234 :=
                       4503599627370494%Z in (* 0xFFFFFFFFFFFFE from consts *)
[::
      (* r0 = x0 *)
zAssign r0 (zVar x0);
      (* r1 = x1 *)
zAssign r1 (zVar x1);
      (* r2 = x2 *)
zAssign r2 (zVar x2);
      (* r3 = x3 *)
zAssign r3 (zVar x3);
      (* r4 = x4 *)
zAssign r4 (zVar x4);
      (* r0 += *[uint64 *] &crypto_sign_ed25519_amd64_51_2P0 *)
zAssign r0 (zBinop zAdd (zVar r0) (zConst crypto_sign_ed25519_amd64_51_2P0));
      (* r1 += *[uint64 *] &crypto_sign_ed25519_amd64_51_2P1234 *)
zAssign r1 (zBinop zAdd (zVar r1) (zConst crypto_sign_ed25519_amd64_51_2P1234));
      (* r2 += *[uint64 *] &crypto_sign_ed25519_amd64_51_2P1234 *)
zAssign r2 (zBinop zAdd (zVar r2) (zConst crypto_sign_ed25519_amd64_51_2P1234));
      (* r3 += *[uint64 *] &crypto_sign_ed25519_amd64_51_2P1234 *)
zAssign r3 (zBinop zAdd (zVar r3) (zConst crypto_sign_ed25519_amd64_51_2P1234));
      (* r4 += *[uint64 *] &crypto_sign_ed25519_amd64_51_2P1234 *)
zAssign r4 (zBinop zAdd (zVar r4) (zConst crypto_sign_ed25519_amd64_51_2P1234));
      (* r0 -= y0 *)
zAssign r0 (zBinop zSub (zVar r0) (zVar y0));
      (* r1 -= y1 *)
zAssign r1 (zBinop zSub (zVar r1) (zVar y1));
      (* r2 -= y2 *)
zAssign r2 (zBinop zSub (zVar r2) (zVar y2));
      (* r3 -= y3 *)
zAssign r3 (zBinop zSub (zVar r3) (zVar y3));
      (* r4 -= y4 *)
zAssign r4 (zBinop zSub (zVar r4) (zVar y4))
      (*  *)
] .

Definition fe25519_mul121666 (X R : bi) : program :=
let '(x0, x1, x2, x3, x4) := X in
let '(r0, r1, r2, r3, r4) := R in
let         wsize :=   64%nat in
let           rax :=  1000 in
let           rdx :=  1001 in

[::
zAssign rax (zVar x0);
zSplit rdx rax (zBinop zMul (zVar rax) (zConst 121666)) 51;
zAssign r0 (zVar rax);
zAssign r1 (zVar rdx);
      (*    *)
zAssign rax (zVar x1);
zSplit rdx rax (zBinop zMul (zVar rax) (zConst 121666)) 51;
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
zAssign r2 (zVar rdx);
      (*    *)
zAssign rax (zVar x2);
zSplit rdx rax (zBinop zMul (zVar rax) (zConst 121666)) 51;
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
zAssign r3 (zVar rdx);
      (*    *)
zAssign rax (zVar x3);
zSplit rdx rax (zBinop zMul (zVar rax) (zConst 121666)) 51;
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
zAssign r4 (zVar rdx);
      (*    *)
zAssign rax (zVar x4);
zSplit rdx rax (zBinop zMul (zVar rax) (zConst 121666)) 51;
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
zAssign rdx (zBinop zMul (zVar rdx) (zConst 19));
zAssign r0 (zBinop zAdd (zVar r0) (zVar rdx))
] .

Definition fe25519_mul (X Y Z : bi) : program :=
let '(x0, x1, x2, x3, x4) := X in
let '(y0, y1, y2, y3, y4) := Y in
let '(z0, z1, z2, z3, z4) := Z in

let         wsize :=   64%nat in

let         carry := 9999 in
let           tmp := 9998 in
let          tmp2 := 9997 in

let            r0 :=  1000 in
let            r1 :=  1001 in
let            r2 :=  1002 in
let            r3 :=  1003 in
let            r4 :=  1004 in

let            c0 :=  1010 in
let            c1 :=  1011 in
let            c2 :=  1012 in
let            c3 :=  1013 in
let            c4 :=  1014 in

let        mulr01 :=  1020 in
let        mulr11 :=  1021 in
let        mulr21 :=  1022 in
let        mulr31 :=  1023 in
let        mulr41 :=  1024 in

let        mulrax :=  1030 in
let        mulrdx :=  1031 in
let          mult :=  1032 in
let    mulredmask :=  1033 in
let       mulx219 :=  1034 in
let       mulx319 :=  1035 in
let       mulx419 :=  1036 in
[::
      (*  *)
      (*   #BEGIN MACRO mul *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   mulrax *= 19 *)
      (*   mulx319_stack = mulrax *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   r0 = mulrax *)
      (*   mulr01 = mulrdx *)
zAssign mulrax (zVar x3);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zAssign mulx319 (zVar mulrax);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r0 (zVar mulrax);
zAssign mulr01 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 32) *)
      (*   mulrax *= 19 *)
      (*   mulx419_stack = mulrax *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x4);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zAssign mulx419 (zVar mulrax);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   r1 = mulrax *)
      (*   mulr11 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r1 (zVar mulrax);
zAssign mulr11 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   r2 = mulrax *)
      (*   mulr21 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r2 (zVar mulrax);
zAssign mulr21 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   r3 = mulrax *)
      (*   mulr31 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r3 (zVar mulrax);
zAssign mulr31 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 0) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   r4 = mulrax *)
      (*   mulr41 = mulrdx *)
zAssign mulrax (zVar x0);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r4 (zVar mulrax);
zAssign mulr41 (zVar mulrdx);
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 8) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x1);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r0 += mulrax *)
      (*   mulr01 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulrax));
zSplit carry r0 (zVar r0) wsize;
zAssign mulr01 (zBinop zAdd (zVar mulr01) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 16) *)
      (*   mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar x2);
zAssign mulrax (zBinop zMul (zVar mulrax) (zConst 19%Z));
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 24) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 8) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x3);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y1)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx319_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar mulx319);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx319_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar mulx319);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = *[uint64 *](xp + 32) *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 0) *)
      (*   carry? r4 += mulrax *)
      (*   mulr41 += mulrdx + carry *)
zAssign mulrax (zVar x4);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y0)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulrax));
zSplit carry r4 (zVar r4) wsize;
zAssign mulr41 (zBinop zAdd (zVar mulr41) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 16) *)
      (*   carry? r1 += mulrax *)
      (*   mulr11 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y2)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulrax));
zSplit carry r1 (zVar r1) wsize;
zAssign mulr11 (zBinop zAdd (zVar mulr11) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 24) *)
      (*   carry? r2 += mulrax *)
      (*   mulr21 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y3)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulrax));
zSplit carry r2 (zVar r2) wsize;
zAssign mulr21 (zBinop zAdd (zVar mulr21) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*   mulrax = mulx419_stack *)
      (*   #mulrax *= 19 *)
      (*   (uint128) mulrdx mulrax = mulrax * *[uint64 *](yp + 32) *)
      (*   carry? r3 += mulrax *)
      (*   mulr31 += mulrdx + carry *)
zAssign mulrax (zVar mulx419);
zSplit mulrdx mulrax (zBinop zMul (zVar mulrax) (zVar y4)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulrax));
zSplit carry r3 (zVar r3) wsize;
zAssign mulr31 (zBinop zAdd (zVar mulr31) (zBinop zAdd (zVar mulrdx) (zVar carry)));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   mulredmask = *[uint64 *] &crypto_sign_ed25519_amd64_51_REDMASK51 *)
      (*   mulr01 = (mulr01.r0) << 13 *)
      (*   r0 &= mulredmask *)
zSplit tmp r0 (zVar r0) 51;
zAssign mulr01 (zBinop zAdd (zmul2p (zVar mulr01) 13) (zVar tmp));
      (*   mulr11 = (mulr11.r1) << 13 *)
      (*   r1 &= mulredmask *)
      (*   r1 += mulr01 *)
zSplit tmp r1 (zVar r1) 51;
zAssign mulr11 (zBinop zAdd (zmul2p (zVar mulr11) 13) (zVar tmp));
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulr01));
      (*   mulr21 = (mulr21.r2) << 13 *)
      (*   r2 &= mulredmask *)
      (*   r2 += mulr11 *)
zSplit tmp r2 (zVar r2) 51;
zAssign mulr21 (zBinop zAdd (zmul2p (zVar mulr21) 13) (zVar tmp));
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulr11));
      (*   mulr31 = (mulr31.r3) << 13 *)
      (*   r3 &= mulredmask *)
      (*   r3 += mulr21 *)
zSplit tmp r3 (zVar r3) 51;
zAssign mulr31 (zBinop zAdd (zmul2p (zVar mulr31) 13) (zVar tmp));
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulr21));
      (*   mulr41 = (mulr41.r4) << 13 *)
      (*   r4 &= mulredmask *)
      (*   r4 += mulr31 *)
zSplit tmp r4 (zVar r4) 51;
zAssign mulr41 (zBinop zAdd (zmul2p (zVar mulr41) 13) (zVar tmp));
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulr31));
      (*   mulr41 = mulr41 * 19 *)
zAssign mulr41 (zBinop zMul (zVar mulr41) (zConst 19%Z));
      (*   r0 += mulr41 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulr41));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   mult = r0 *)
      (*   (uint64) mult >>= 51 *)
      (*   mult += r1 *)
zAssign mult (zVar r0);
zSplit mult tmp (zVar mult) 51;
zAssign mult (zBinop zAdd (zVar mult) (zVar r1));
      (*   r1 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r0 &= mulredmask *)
      (*   mult += r2 *)
zAssign r1 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r0 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r2));
      (*   r2 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r1 &= mulredmask *)
      (*   mult += r3 *)
zAssign r2 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r1 (zVar tmp2);
zAssign mult (zBinop zAdd (zVar mult) (zVar r3));
      (*   r3 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r2 &= mulredmask *)
      (*   mult += r4 *)
zAssign r3 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r2 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r4));
      (*   r4 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r3 &= mulredmask *)
zAssign r4 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r3 (zVar tmp2);
      (*   mult *= 19 *)
      (*   r0 += mult *)
      (*   r4 &= mulredmask *)
zAssign mult (zBinop zMul (zVar mult) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar mult));
zAssign r4 (zVar tmp);
      (*   #END MACRO mul *)

      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
      (* *[uint64 *](rp + 8) = r1 *)
      (* *[uint64 *](rp + 16) = r2 *)
      (* *[uint64 *](rp + 24) = r3 *)
      (* *[uint64 *](rp + 32) = r4 *)
zAssign z0 (zVar r0);
zAssign z1 (zVar r1);
zAssign z2 (zVar r2);
zAssign z3 (zVar r3);
zAssign z4 (zVar r4)
      (*  *)

      (* c1 =c1_stack *)
      (* c2 =c2_stack *)
      (* c3 =c3_stack *)
      (* c4 =c4_stack *)
      (* c5 =c5_stack *)
      (* c6 =c6_stack *)
      (* c7 =c7_stack *)
      (*  *)

      (* leave *)
] .

Definition fe25519_sq (X Z : bi) : program :=
let '(x0, x1, x2, x3, x4) := X in
let '(z0, z1, z2, z3, z4) := Z in

let         wsize :=   64%nat in

let            r0 :=  1000 in
let            r1 :=  1001 in
let            r2 :=  1002 in
let            r3 :=  1003 in
let            r4 :=  1004 in

let            c1 :=  1011 in
let            c2 :=  1012 in
let            c3 :=  1013 in
let            c4 :=  1014 in
let            c5 :=  1015 in
let            c6 :=  1016 in
let            c7 :=  1017 in

let          x119 :=  1021 in
let          x219 :=  1022 in
let          x319 :=  1023 in
let          x419 :=  1024 in

let           r01 :=  1030 in
let           r11 :=  1031 in
let           r21 :=  1032 in
let           r31 :=  1033 in
let           r41 :=  1034 in
let           rax :=  1035 in
let           rdx :=  1036 in

let             t :=  1040 in
let       redmask :=  1041 in

let           tmp := 9998 in
let         carry := 9999 in

[::
      (*  *)
      (* int64 rp *)
      (* int64 xp *)
      (*  *)
      (* input rp *)
      (* input xp *)
      (*  *)
      (* int64 r0 *)
      (* int64 r1 *)
      (* int64 r2 *)
      (* int64 r3 *)
      (* int64 r4 *)
      (*  *)
      (* int64 c1 *)
      (* int64 c2 *)
      (* int64 c3 *)
      (* int64 c4 *)
      (* int64 c5 *)
      (* int64 c6 *)
      (* int64 c7 *)
      (* caller c1 *)
      (* caller c2 *)
      (* caller c3 *)
      (* caller c4 *)
      (* caller c5 *)
      (* caller c6 *)
      (* caller c7 *)
      (* stack64 c1_stack *)
      (* stack64 c2_stack *)
      (* stack64 c3_stack *)
      (* stack64 c4_stack *)
      (* stack64 c5_stack *)
      (* stack64 c6_stack *)
      (* stack64 c7_stack *)
      (* stack64 x119_stack *)
      (* stack64 x219_stack *)
      (* stack64 x319_stack *)
      (* stack64 x419_stack *)
      (*  *)

      (* #required for  macro *)

      (* int64 r01 *)
      (* int64 r11 *)
      (* int64 r21 *)
      (* int64 r31 *)
      (* int64 r41 *)
      (* int64 rax *)
      (* int64 rdx *)

      (* int64 t *)
      (* int64 redmask *)

      (*  *)
      (* enter fe25519_sq *)
      (*  *)
      (* c1_stack = c1 *)
      (* c2_stack = c2 *)
      (* c3_stack = c3 *)
      (* c4_stack = c4 *)
      (* c5_stack = c5 *)
      (* c6_stack = c6 *)
      (* c7_stack = c7 *)
      (*  *)
      (*   #BEGIN MACRO  *)
      (*   rax = *[uint64 *](xp + 0) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 0) *)
      (*   r0 = rax *)
      (*   r01 = rdx *)
zAssign rax (zVar x0);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x0)) wsize;
zAssign r0 (zVar rax);
zAssign r01 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   r1 = rax *)
      (*   r11 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x1)) wsize;
zAssign r1 (zVar rax);
zAssign r11 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   r2 = rax *)
      (*   r21 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r2 (zVar rax);
zAssign r21 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   r3 = rax *)
      (*   r31 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r3 (zVar rax);
zAssign r31 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   r4 = rax *)
      (*   r41 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r4 (zVar rax);
zAssign r41 (zVar rdx);
      (*  *)
      (*   rax = *[uint64 *](xp + 8) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
zAssign rax (zVar x1);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x1)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
zSplit carry r2 (zVar r2) wsize;
zAssign r21 (zBinop zAdd (zVar r21) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
zSplit carry r3 (zVar r3) wsize;
zAssign r31 (zBinop zAdd (zVar r31) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
zSplit carry r4 (zVar r4) wsize;
zAssign r41 (zBinop zAdd (zVar r41) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar rax));
zSplit carry r0 (zVar r0) wsize;
zAssign r01 (zBinop zAdd (zVar r01) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 16) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
zAssign rax (zVar x2);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
zSplit carry r4 (zVar r4) wsize;
zAssign r41 (zBinop zAdd (zVar r41) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
zAssign rax (zVar x2);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar rax));
zSplit carry r0 (zVar r0) wsize;
zAssign r01 (zBinop zAdd (zVar r01) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
zAssign rax (zVar x2);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
zSplit carry r1 (zVar r1) wsize;
zAssign r11 (zBinop zAdd (zVar r11) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
zAssign rax (zVar x3);
zAssign rax (zBinop zMul (zVar rax) (zConst 19%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
zSplit carry r1 (zVar r1) wsize;
zAssign r11 (zBinop zAdd (zVar r11) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
zAssign rax (zVar x3);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
zSplit carry r2 (zVar r2) wsize;
zAssign r21 (zBinop zAdd (zVar r21) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 32) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
zAssign rax (zVar x4);
zAssign rax (zBinop zMul (zVar rax) (zConst 19%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
zSplit carry r3 (zVar r3) wsize;
zAssign r31 (zBinop zAdd (zVar r31) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   redmask = *[uint64 *] &crypto_sign_ed25519_amd64_51_REDMASK51 *)
      (*   r01 = (r01.r0) << 13 *)
      (*   r0 &= redmask *)
zSplit tmp r0 (zVar r0) 51;
zAssign r01 (zBinop zAdd (zmul2p (zVar r01) 13) (zVar tmp));
      (*    *)
      (*   r11 = (r11.r1) << 13 *)
      (*   r1 &= redmask *)
      (*   r1 += r01 *)
zSplit tmp r1 (zVar r1) 51;
zAssign r11 (zBinop zAdd (zmul2p (zVar r11) 13) (zVar tmp));
zAssign r1 (zBinop zAdd (zVar r1) (zVar r01));
      (*    *)
      (*   r21 = (r21.r2) << 13 *)
      (*   r2 &= redmask *)
      (*   r2 += r11 *)
zSplit tmp r2 (zVar r2) 51;
zAssign r21 (zBinop zAdd (zmul2p (zVar r21) 13) (zVar tmp));
zAssign r2 (zBinop zAdd (zVar r2) (zVar r11));
      (*    *)
      (*   r31 = (r31.r3) << 13 *)
      (*   r3 &= redmask *)
      (*   r3 += r21 *)
zSplit tmp r3 (zVar r3) 51;
zAssign r31 (zBinop zAdd (zmul2p (zVar r31) 13) (zVar tmp));
zAssign r3 (zBinop zAdd (zVar r3) (zVar r21));
      (*    *)
      (*   r41 = (r41.r4) << 13 *)
      (*   r4 &= redmask *)
      (*   r4 += r31 *)
zSplit tmp r4 (zVar r4) 51;
zAssign r41 (zBinop zAdd (zmul2p (zVar r41) 13) (zVar tmp));
zAssign r4 (zBinop zAdd (zVar r4) (zVar r31));
      (*   r41 = r41 * 19 *)
zAssign r41 (zBinop zMul (zVar r41) (zConst 19%Z));
      (*   r0 += r41 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar r41));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   t = r0 *)
      (*   (uint64) t >>= 51 *)
      (*   t += r1 *)
      (*   r0 &= redmask *)
zAssign t (zVar r0);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r1));
zAssign r0 (zVar tmp);
      (*    *)
      (*   r1 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r2 *)
      (*   r1 &= redmask *)
zAssign r1 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r2));
zAssign r1 (zVar tmp);
      (*    *)
      (*   r2 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r3 *)
      (*   r2 &= redmask *)
zAssign r2 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r3));
zAssign r2 (zVar tmp);
      (*    *)
      (*   r3 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r4 *)
      (*   r3 &= redmask *)
zAssign r3 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r4));
zAssign r3 (zVar tmp);
      (*    *)
      (*   r4 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t *= 19 *)
      (*   r0 += t *)
      (*   r4 &= redmask *)
zAssign r4 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zMul (zVar t) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar t));
zAssign r4 (zVar tmp);
      (*   #END MACRO  *)
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
zAssign z0 (zVar r0);
      (* *[uint64 *](rp + 8) = r1 *)
zAssign z1 (zVar r1);
      (* *[uint64 *](rp + 16) = r2 *)
zAssign z2 (zVar r2);
      (* *[uint64 *](rp + 24) = r3 *)
zAssign z3 (zVar r3);
      (* *[uint64 *](rp + 32) = r4 *)
zAssign z4 (zVar r4)
      (*   *)
      (*  *)
      (* c1 =c1_stack *)
      (* c2 =c2_stack *)
      (* c3 =c3_stack *)
      (* c4 =c4_stack *)
      (* c5 =c5_stack *)
      (* c6 =c6_stack *)
      (* c7 =c7_stack *)
      (*  *)
      (* leave *)
] .

Definition fe25519_ladderstep : program :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
fe25519_add X2 Z2 T1 ++
fe25519_sub X2 Z2 T2 ++
fe25519_sq T2 T7 ++
fe25519_sq T1 T6 ++
fe25519_sub T6 T7 T5 ++
fe25519_add X3 Z3 T3 ++
fe25519_sub X3 Z3 T4 ++
fe25519_mul T3 T2 T9 ++
fe25519_mul T4 T1 T8 ++
fe25519_add T8 T9 X3_1 ++
fe25519_sub T8 T9 Z3_1 ++
fe25519_sq X3_1 X3' ++
fe25519_sq Z3_1 Z3_2 ++
fe25519_mul Z3_2 X1 Z3' ++
fe25519_mul T6 T7 X2' ++
fe25519_mul121666 T5 Z2_1 ++
fe25519_add Z2_1 T7 Z2_2 ++
fe25519_mul Z2_2 T5 Z2'.

Definition fe25519_ladderstep_inputs : VS.t :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
VSLemmas.OP.P.of_list (bi_list X1 ++ bi_list X2 ++ bi_list Z2 ++
                               bi_list X3 ++ bi_list Z3).

Definition fe25519_ladderstep_pre : bexp := zTrue.

Definition fe25519_ladderstep_post1 : bexp :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (bi_limbs X2')
  (zPow (zsub (zPow (bi_limbs X2) 2) (zPow (bi_limbs Z2) 2)) 2)
  (zConst n25519).

Definition fe25519_ladderstep_post2 : bexp :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (bi_limbs Z2')
  (zmuls [:: zConst 4;
            bi_limbs X2;
            bi_limbs Z2;
            zadds [:: zPow (bi_limbs X2) 2;
                     zmuls [:: zConst 486662; bi_limbs X2; bi_limbs Z2];
                     zPow (bi_limbs Z2) 2]
         ])
  (zConst n25519).

Definition fe25519_ladderstep_post3 : bexp :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (zmul (bi_limbs X3')
        (zmul (bi_limbs X1)
              (zPow (zsub (zmul (bi_limbs X3) (bi_limbs Z2))
                          (zmul (bi_limbs X2) (bi_limbs Z3))) 2)))
  (zmul (bi_limbs Z3')
        (zPow (zsub (zmul (bi_limbs X2) (bi_limbs X3))
                    (zmul (bi_limbs Z2) (bi_limbs Z3))) 2))
  (zConst n25519).

Definition fe25519_ladderstep_post3_1 : bexp :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (bi_limbs X3')
  (zmul (zConst 4)
        (zPow (zsub (zmul (bi_limbs X2) (bi_limbs X3))
                    (zmul (bi_limbs Z2) (bi_limbs Z3))) 2))
  (zConst n25519).

Definition fe25519_ladderstep_post3_2 : bexp :=
let X1   := (10, 11, 12, 13, 14) in
let X2   := (20, 21, 22, 23, 24) in
let X2'  := (30, 31, 32, 33, 34) in
let Z2   := (40, 41, 42, 43, 44) in
let Z2_1 := (50, 51, 52, 53, 54) in
let Z2_2 := (60, 61, 62, 63, 64) in
let Z2'  := (70, 71, 72, 73, 74) in
let X3   := (80, 81, 82, 83, 84) in
let X3_1 := (90, 91, 92, 93, 94) in
let X3'  := (100, 101, 102, 103, 104) in
let Z3   := (110, 111, 112, 113, 114) in
let Z3_1 := (120, 121, 122, 123, 124) in
let Z3_2 := (130, 131, 132, 133, 134) in
let Z3'  := (140, 141, 142, 143, 144) in
let T1   := (150, 151, 152, 153, 154) in
let T2   := (160, 161, 162, 163, 164) in
let T3   := (170, 171, 172, 173, 174) in
let T4   := (180, 181, 182, 183, 184) in
let T5   := (190, 191, 192, 193, 194) in
let T6   := (200, 201, 202, 203, 204) in
let T7   := (210, 211, 212, 213, 214) in
let T8   := (220, 221, 222, 223, 224) in
let T9   := (230, 231, 232, 233, 234) in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (bi_limbs Z3')
  (zmul (zConst 4)
        (zmul (bi_limbs X1)
              (zPow (zsub (zmul (bi_limbs X3) (bi_limbs Z2))
                          (zmul (bi_limbs X2) (bi_limbs Z3))) 2)))
  (zConst n25519).

Definition fe25519_ladderstep_post : bexp :=
  zands [:: fe25519_ladderstep_post1;
            fe25519_ladderstep_post2;
            fe25519_ladderstep_post3 ].

Definition fe25519_ladderstep_spec :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post |}.

Definition fe25519_ladderstep_spec1 :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post1 |}.

Definition fe25519_ladderstep_spec2 :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post2 |}.

Definition fe25519_ladderstep_spec3 :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post3 |}.

Definition fe25519_ladderstep_spec3_1 :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post3_1 |}.

Definition fe25519_ladderstep_spec3_2 :=
  {| spre := fe25519_ladderstep_pre;
     sprog := fe25519_ladderstep;
     spost := fe25519_ladderstep_post3_2 |}.

From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_ladderstep3_2 : valid_zspec (fe25519_ladderstep_inputs, fe25519_ladderstep_spec3_2).
Proof.
  time "valid_fe25519_ladderstep3_2" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


(************************************************************************)
(*  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.

 Variable wm w : Type.
 Variable w_0 : w.
 Variable compare : w -> w -> comparison.
 Variable compare0_m : wm -> comparison.
 Variable compare_m : wm -> w -> comparison.

 Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
  match n return word wm n -> comparison with
  | O => compare0_m
  | S m => fun x =>
    match x with
    | W0 => Eq
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare0_mn m xl
      | r  => Lt
      end
    end
  end.

 Variable wm_base: positive.
 Variable wm_to_Z: wm -> Z.
 Variable w_to_Z: w -> Z.
 Variable w_to_Z_0: w_to_Z w_0 = 0.
 Variable spec_compare0_m: forall x,
   compare0_m x = (w_to_Z w_0 ?= wm_to_Z x).
 Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base.

 Let double_to_Z := double_to_Z wm_base wm_to_Z.
 Let double_wB := double_wB wm_base.

 Lemma base_xO: forall n, base (xO n) = (base n)^2.
 Proof.
 intros n1; unfold base.
 rewrite (Pos2Z.inj_xO n1); rewrite Z.mul_comm; rewrite Z.pow_mul_r; auto with zarith.
 Qed.

 Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n :=
   (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos).

 Declare Equivalent Keys compare0_mn compare0_m.

 Lemma spec_compare0_mn: forall n x,
   compare0_mn n x = (0 ?= double_to_Z n x).
 Proof.
  intros n; elim n; clear n; auto.
  intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto.
  intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto.
  fold word in *.
  intros xh xl.
  rewrite 2 Hrec.
  simpl double_to_Z.
  set (wB := DoubleBase.double_wB wm_base n).
  case Z.compare_spec; intros Cmp.
  rewrite <- Cmp. reflexivity.
  symmetry. apply Z.gt_lt, Z.lt_gt. (* ;-) *)
  assert (0 < wB).
   unfold wB, DoubleBase.double_wB, base; auto with zarith.
  change 0 with (0 + 0); apply Z.add_lt_le_mono; auto with zarith.
  apply Z.mul_pos_pos; auto with zarith.
  case (double_to_Z_pos n xl); auto with zarith.
  case (double_to_Z_pos n xh); intros; exfalso; omega.
  Qed.

 Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
  match n return word wm n -> w -> comparison with
  | O => compare_m
  | S m => fun x y =>
    match x with
    | W0 => compare w_0 y
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare_mn_1 m xl y
      | r  => Gt
      end
    end
  end.

 Variable spec_compare: forall x y,
   compare x y = Z.compare (w_to_Z x) (w_to_Z y).
 Variable spec_compare_m: forall x y,
   compare_m x y = Z.compare (wm_to_Z x) (w_to_Z y).
 Variable wm_base_lt: forall x,
   0 <= w_to_Z x < base (wm_base).

 Let double_wB_lt: forall n x,
   0 <= w_to_Z x < (double_wB n).
 Proof.
 intros n x; elim n; simpl; auto; clear n.
 intros n (H0, H); split; auto.
 apply Z.lt_le_trans with (1:= H).
 unfold double_wB, DoubleBase.double_wB; simpl.
 rewrite base_xO.
 set (u := base (Pos.shiftl_nat wm_base n)).
 assert (0 < u).
  unfold u, base; auto with zarith.
 replace (u^2) with (u * u); simpl; auto with zarith.
 apply Z.le_trans with (1 * u); auto with zarith.
 unfold Z.pow_pos; simpl; ring.
 Qed.

 Lemma spec_compare_mn_1: forall n x y,
   compare_mn_1 n x y = Z.compare (double_to_Z n x) (w_to_Z y).
 Proof.
 intros n; elim n; simpl; auto; clear n.
 intros n Hrec x; case x; clear x; auto.
 intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity.
 intros xh xl y; simpl;
 rewrite spec_compare0_mn, Hrec. case Z.compare_spec.
 intros H1b.
 rewrite <- H1b; rewrite Z.mul_0_l; rewrite Z.add_0_l; auto.
 symmetry. apply Z.lt_gt.
 case (double_wB_lt n y); intros _ H0.
 apply Z.lt_le_trans with (1:= H0).
 fold double_wB.
 case (double_to_Z_pos n xl); intros H1 H2.
 apply Z.le_trans with (double_to_Z n xh * double_wB n); auto with zarith.
 apply Z.le_trans with (1 * double_wB n); auto with zarith.
 case (double_to_Z_pos n xh); intros; exfalso; omega.
 Qed.

End CompareRec.

Section AddS.

 Variable w wm : Type.
 Variable incr : wm -> carry wm.
 Variable addr : w -> wm -> carry wm.
 Variable injr : w -> zn2z wm.

 Variable w_0 u: w.
 Fixpoint injs  (n:nat): word w (S n) :=
  match n return (word w (S n)) with
    O => WW w_0 u
  | S n1 => (WW W0 (injs n1))
  end.

 Definition adds x y :=
   match y with
    W0 => C0 (injr x)
  | WW hy ly => match addr x ly with
                  C0 z => C0 (WW hy z)
                | C1 z => match incr hy with
                            C0 z1 => C0 (WW z1 z)
                          | C1 z1 => C1 (WW z1 z)
                          end
                 end
   end.

End AddS.

 Fixpoint length_pos x :=
  match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end.

 Theorem length_pos_lt: forall x y,
   (length_pos x < length_pos y)%nat -> Zpos x < Zpos y.
 Proof.
 intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac];
   intros y; case y; clear y; intros y1 H || intros H; simpl length_pos;
   try (rewrite (Pos2Z.inj_xI x1) || rewrite (Pos2Z.inj_xO x1));
   try (rewrite (Pos2Z.inj_xI y1) || rewrite (Pos2Z.inj_xO y1));
   try (inversion H; fail);
   try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith);
   assert (0 < Zpos y1); auto with zarith; red; auto.
 Qed.

 Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x.
 Proof.
 intros A B f g x H; rewrite H; auto.
 Qed.

 Section SimplOp.

 Variable w: Type.

 Theorem digits_zop: forall t (ops : ZnZ.Ops t),
  ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops).
 Proof.
 intros ww x; auto.
 Qed.

 Theorem digits_kzop: forall t (ops : ZnZ.Ops t),
  ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops).
 Proof.
 intros ww x; auto.
 Qed.

 Theorem make_zop: forall t (ops : ZnZ.Ops t),
  @ZnZ.to_Z _ (mk_zn2z_ops ops) =
    fun z => match z with
             | W0 => 0
             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
                                + ZnZ.to_Z xl
             end.
 Proof.
 intros ww x; auto.
 Qed.

 Theorem make_kzop: forall t (ops: ZnZ.Ops t),
  @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) =
    fun z => match z with
             | W0 => 0
             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
                                + ZnZ.to_Z xl
             end.
 Proof.
 intros ww x; auto.
 Qed.

 End SimplOp.

(** Abstract vision of a datatype of arbitrary-large numbers.
    Concrete operations can be derived from these generic
    fonctions, in particular from [iter_t] and [same_level].
*)

Module Type NAbstract.

(** The domains: a sequence of [Z/nZ] structures *)

Parameter dom_t : nat -> Type.
Declare Instance dom_op n : ZnZ.Ops (dom_t n).
Declare Instance dom_spec n : ZnZ.Specs (dom_op n).

Axiom digits_dom_op : forall n,
  ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op 0)) n.

(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t]
    and destructor [destr_t] and iterator [iter_t] *)

Parameter t : Type.

Parameter mk_t : forall (n:nat), dom_t n -> t.

Inductive View_t : t -> Prop :=
 Mk_t : forall n (x : dom_t n), View_t (mk_t n x).

Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *)

Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A.

Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A),
 forall n x, iter_t f (mk_t n x) = f n x.

(** Conversion to [ZArith] *)

Parameter to_Z : t -> Z.
Local Notation "[ x ]" := (to_Z x).

Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x.

(** [reduce] is like [mk_t], but try to minimise the level of the number *)

Parameter reduce : forall (n:nat), dom_t n -> t.
Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x.

(** Number of level in the tree representation of a number.
    NB: This function isn't a morphism for setoid [eq]. *)

Definition level := iter_t (fun n _ => n).

(** [same_level] and its rich specification, indexed by [level] *)

Parameter same_level : forall {A:Type}
 (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A.

Axiom spec_same_level_dep :
  forall res
   (P : nat -> Z -> Z -> res -> Prop)
   (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r)
   (f : forall n, dom_t n -> dom_t n -> res)
   (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)),
   forall x y, P (level x) [x] [y] (same_level f x y).

(** [mk_t_S] : building a number of the next level *)

Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t.

Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)),
  [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.

Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n.

End NAbstract.


Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import CoqStock.comparable.
Require Import CoqStock.List.

Require Import Reexamined.regex.

Fixpoint size {A: Type} {cmp: comparable A} (r: regex A) :=
  match r with
  | fail => 1
  | empty => 1
  | char _ => 1
  | (or s t) => 1 + size s + size t
  | (and s t) => 1 + size s + size t
  | (concat s t) => 1 + size s + size t
  | (not s) => 1 + size s
  | (star s) => 1 + size s
  end.