Require Import Utf8_core.
Require ILLVarInt. (* Don't want import it. *)
Import ILLVarInt.MILL. (* only this *)
Import FormulaMultiSet. (* and this *)
Require Import narrative.

Module Proof_eq.

(* Implicit Types Γ Δ : env. *)
(* Implicit Types f φ p q : formula. *)
  Set Implicit Arguments.

  Inductive eq: ∀ Γ Γ' f, (Γ ⊢ f) → (Γ' ⊢ f) → Prop :=
  | EQId: ∀ Γ1 Γ2, ∀ f, ∀ heq heq', eq (Id Γ1 f heq) (Id Γ2 f heq')
  | EQImpl_R: ∀ Γ1 Γ2 p q h h',  eq h h' → eq (Impl_R Γ1 p q h) (Impl_R Γ2 p q h')
  | EQImpl_L: ∀ Γ1 Δ1 Δ1' Γ2 Δ2 Δ2', ∀ p q r, ∀ heq1 heq1' heq2 heq2' h1 h1' h2 h2',
    eq h1 h1' → eq h2 h2'
    → eq (Impl_L Γ1 Δ1 Δ1' p q r heq1 heq2 h1 h2) (Impl_L Γ2 Δ2 Δ2' p q r heq1' heq2' h1' h2')
  | EQTimes_R: ∀ Γ1 Δ1 Δ1' Γ2 Δ2 Δ2' p q heq heq' h1 h1' h2 h2',
    eq h1 h1' → eq h2 h2' → eq (Times_R Γ1 Δ1 Δ1' p q heq h1 h2) (Times_R Γ2 Δ2 Δ2' p q heq' h1' h2')
  | EQTimes_L: ∀ Γ1 Γ2, ∀ p q r, ∀ hin hin' h h', eq h h' →
    eq (Times_L Γ1 p q r hin h) (Times_L Γ2 p q r hin' h')
  | EQOne_R: ∀ Γ1 Γ2, ∀ heq heq', eq (One_R Γ1 heq) (One_R Γ2 heq')
  | EQOne_L: ∀ Γ1 Γ2, ∀ p, ∀ hin hin' h h', eq h h' → eq (One_L Γ1 p hin h) (One_L Γ2 p hin' h')
  | EQAnd_R: ∀ Γ1 Γ2, ∀ p q, ∀ h1 h1' h2 h2', eq h1 h1' → eq h2 h2' → eq (And_R  Γ1 p q h1 h2) (And_R  Γ2 p q h1' h2')
  | EQAnd_L_2: ∀ Γ1 Γ2 p q r hin hin' h h', eq h h' → eq (And_L_2 Γ1 p q r hin h) (And_L_2 Γ2 p q r hin' h')
  | EQAnd_L_1: ∀ Γ1 Γ2 p q r hin hin' h h', eq h h' → eq (And_L_1 Γ1 p q r hin h) (And_L_1 Γ2 p q r hin' h')
  | EQOplus_L: ∀ Γ1 Γ2 p q r hin hin' h1 h1' h2 h2', eq h1 h1' → eq h2 h2' → eq (Oplus_L Γ1 p q r hin h1 h2) (Oplus_L Γ2 p q r hin' h1' h2')
  | EQOplus_R_2: ∀ Γ1 Γ2 p q h h', eq h h'  → eq (Oplus_R_2 Γ1 p q h) (Oplus_R_2 Γ2 p q h')
  | EQOplus_R_1: ∀ Γ1 Γ2 p q h h', eq h h' → eq (Oplus_R_1 Γ1 p q h) (Oplus_R_1 Γ2 p q h')
  | EQT_ : ∀ Γ1 Γ2, eq (T_ Γ1) (T_ Γ2) (* Γ1 == Γ2 ? *)
  | EQZero_: ∀ Γ1 Γ2 p hin hin', eq (Zero_ Γ1 p hin) (Zero_ Γ2 p hin')
  | EQBang_D: ∀ Γ1 Γ2 p q hin hin' h h', eq h h' → eq (Bang_D Γ1 p q hin h) (Bang_D Γ2 p q hin' h')
  | EQBang_C: ∀ Γ1 Γ2 p q hin hin' h h', eq h h' → eq (Bang_C Γ1 p q hin h) (Bang_C Γ2 p q hin' h')
  | EQBang_W: ∀ Γ1 Γ2 p q hin hin' h h', eq h h' → eq (Bang_W Γ1 p q hin h) (Bang_W Γ2 p q hin' h')
(* inutile si pred est compatible avec == *)
    .

  Lemma refl : ∀ φ Γ (h:Γ ⊢ φ), eq h h.
  Proof.
    fix refl 3.
    intros φ Γ h.
    case h;constructor;apply refl.
  Qed.

  Lemma sym : ∀ φ Γ Γ' (h1:Γ⊢φ) (h2:Γ'⊢φ), eq h1 h2 -> eq h2 h1.
  Proof.
    fix sym 6.
    intros φ Γ Γ' h1 h2 H.
    case H; intros; now (constructor; apply sym).
  Qed.

  Lemma eq_pre_morph : ∀ φ Γ (h:Γ ⊢ φ) Γ' (heqΓ: Γ == Γ') , eq (ILL_proof_pre_morph φ Γ Γ' heqΓ h) h.
  Proof.
    fix eq_pre_morph 3.
    intros φ Γ h.
    case h; intros; simpl; solve [ constructor; try apply refl; try apply eq_pre_morph].
  Qed.
End Proof_eq.

Module nu_eq.

  Set Implicit Arguments.

  Definition eq Γ Γ' f f' (h:Γ⊢f) (h':Γ'⊢f') : Prop  :=
    (ν _ _ h) = (ν _ _ h').

  Lemma refl : ∀ φ Γ (h:Γ ⊢ φ), eq h h.
  Proof.
    reflexivity.
  Qed.

  Lemma sym : ∀ φ Γ Γ' (h1:Γ⊢φ) (h2:Γ'⊢φ), eq h1 h2 -> eq h2 h1.
  Proof.
    intros φ Γ Γ' h1 h2.
    unfold eq.
    intros H.
    symmetry.
    assumption.
  Qed.

  Lemma eq_pre_morph : ∀ φ Γ (h:Γ ⊢ φ) Γ' (heqΓ: Γ == Γ') , eq (ILL_proof_pre_morph φ Γ Γ' heqΓ h) h.
  Proof.
    fix eq_pre_morph 3.
    intros φ Γ h.
    case h; intros; simpl; unfold eq in *; simpl;
      solve [reflexivity | setoid_rewrite eq_pre_morph; reflexivity].
  Qed.

End nu_eq.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export aire_signee.
Require Export metrique_triangle.
Set Implicit Arguments.
Unset Strict Implicit.
Parameters (O : PO) (I : PO) (J : PO).
Axiom OIJ : repere_orthonormal_direct O I J.
#[export] Hint Resolve OIJ: geo.

Lemma OIJ_repere_ortho : repere_orthonormal O I J.
auto with geo.
Qed.

Lemma OIJ_repere : repere O I J.
auto with geo.
Qed.

Lemma OI_distincts : O <> I.
elim OIJ; intros.
auto with geo.
elim H0; intros; auto with geo.
Qed.

Lemma OJ_distincts : O <> J.
elim OIJ; intros.
elim H0; intros; auto with geo.
Qed.
#[export] Hint Resolve OIJ_repere_ortho OIJ_repere OI_distincts OJ_distincts: geo.

Lemma IJ_distincts : I <> J.
cut (repere_orthonormal O I J); intros; auto with geo.
elim H; intros.
apply non_alignes_distincts2 with O; auto.
apply orthogonal_non_alignes; auto with geo.
Qed.
#[export] Hint Resolve IJ_distincts: geo.

Ltac deroule_OIJ :=
  elim OIJ; intro; intros toto; elim toto; intros; clear toto;
   cut (distance O I = 1); intros; [ idtac | auto with geo ];
   cut (distance O J = 1); intros; [ idtac | auto with geo ].

Lemma unite_aire : aire (vec O I) (vec O J) = 1.
intros.
deroule_OIJ.
rewrite def_aire; auto with geo.
rewrite (def_Sin (A:=O) (B:=I) (C:=J) (D:=J)); auto with geo.
rewrite H1; rewrite H2; rewrite H3; ring.
Qed.

Lemma opp_unite_aire : aire (vec O J) (vec O I) = -1.
intros.
deroule_OIJ.
rewrite def_aire; auto with geo.
rewrite Sin_opp; auto with geo.
rewrite (def_Sin (A:=O) (B:=I) (C:=J) (D:=J)); auto with geo.
rewrite H1; rewrite H2; rewrite H3; ring.
Qed.
Parameter det : PP -> PP -> R.

Axiom
  determinant_def :
    forall (A B C D : PO) (x y x' y' : R),
    vec A B = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)) ->
    vec C D = add_PP (mult_PP x' (vec O I)) (mult_PP y' (vec O J)) ->
    det (vec A B) (vec C D) = x * y' + - (y * x').

Lemma aire_coordonnees :
 forall (M N : PO) (x y x' y' : R),
 vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)) ->
 vec O N = add_PP (mult_PP x' (vec O I)) (mult_PP y' (vec O J)) ->
 aire (vec O M) (vec O N) = x * y' + - (y * x').
intros.
rewrite H.
elim
 existence_representant_mult_vecteur with (A := O) (B := O) (C := I) (k := x);
 [ intros A H1; rewrite <- H1 ].
elim
 existence_representant_mult_vecteur with (A := O) (B := O) (C := J) (k := y);
 [ intros B H2; rewrite <- H2 ].
rewrite aire_distrib_r.
rewrite H1.
rewrite aire_colineaire_l.
rewrite H2.
rewrite aire_colineaire_l.
rewrite H0.
elim
 existence_representant_mult_vecteur
  with (A := O) (B := O) (C := I) (k := x'); [ intros C H3; rewrite <- H3 ].
elim
 existence_representant_mult_vecteur
  with (A := O) (B := O) (C := J) (k := y'); [ intros D H4; rewrite <- H4 ].
repeat rewrite aire_distrib_l.
rewrite H3.
repeat rewrite aire_colineaire_r.
rewrite H4.
repeat rewrite aire_colineaire_r.
repeat rewrite aire_ABAB.
rewrite unite_aire.
rewrite opp_unite_aire.
ring.
Qed.

Lemma determinant_aire :
 forall A B C D : PO, det (vec A B) (vec C D) = aire (vec A B) (vec C D).
intros.
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := A) (N := B);
 [ intros x H; elim H;
    [ intros y H0; try clear H composantes_vecteur; try exact H0 ]
 | auto with geo ].
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := C) (N := D);
 [ intros x' H1; elim H1;
    [ intros y' H2; try clear H1 composantes_vecteur; try exact H2 ]
 | auto with geo ].
rewrite
 (determinant_def (A:=A) (B:=B) (C:=C) (D:=D) (x:=x) (y:=y) (x':=x') (y':=y'))
 ; auto.
generalize H0 H2.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros E H3; rewrite <- H3 ].
elim existence_representant_vecteur with (A := O) (B := C) (C := D);
 [ intros F H4; rewrite <- H4 ].
intros; symmetry  in |- *.
apply aire_coordonnees; auto.
Qed.

Lemma determinant_antisymetrique :
 forall A B C D : PO, det (vec A B) (vec C D) = - det (vec C D) (vec A B).
intros.
repeat rewrite determinant_aire.
rewrite aire_anti_symetrique; auto.
Qed.

Lemma determinant_colinearite :
 forall (k : R) (A B C D : PO),
 vec C D = mult_PP k (vec A B) -> det (vec A B) (vec C D) = 0.
intros.
repeat rewrite determinant_aire.
apply (aire_colinearite H).
Qed.

Lemma determinant_nul_colinearite :
 forall A B C D : PO,
 A <> B ->
 det (vec A B) (vec C D) = 0 -> exists k : _, vec C D = mult_PP k (vec A B).
intros A B C D H; try assumption.
rewrite determinant_aire; intros.
apply aire_nulle_colineaires; auto.
Qed.

Lemma alignement_determinant :
 forall A B M : PO, alignes A B M -> det (vec A B) (vec A M) = 0.
intros.
rewrite determinant_aire.
apply aire_alignement; auto.
Qed.

Lemma determinant_nul_alignement :
 forall A B M : PO, det (vec A B) (vec A M) = 0 -> alignes A B M.
intros.
discrimine A B.
elim determinant_nul_colinearite with (A := A) (B := B) (C := A) (D := M);
 [ intros k H1; try clear determinant_nul_colinearite; try exact H1
 | auto
 | auto ].
apply colineaire_alignes with k; auto.
Qed.

Lemma determinant_colineaire_l :
 forall (k : R) (A B C D : PO),
 det (mult_PP k (vec A B)) (vec C D) = k * det (vec A B) (vec C D).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := k);
 [ intros E H1; rewrite <- H1 ].
repeat rewrite determinant_aire.
rewrite H1.
apply aire_colineaire_l.
Qed.

Lemma determinant_distrib_l :
 forall A B C D E F : PO,
 det (vec A B) (add_PP (vec C D) (vec E F)) =
 det (vec A B) (vec C D) + det (vec A B) (vec E F).
intros.
elim
 existence_representant_som_vecteur with (A := C) (B := D) (C := E) (D := F);
 [ intros G H; try clear existence_representant_som_vecteur; rewrite <- H ].
repeat rewrite determinant_aire.
rewrite H.
apply aire_distrib_l.
Qed.

Lemma determinant_ordre_cycle :
 forall A B C D E F : PO, det (vec B C) (vec B A) = det (vec A B) (vec A C).
intros.
repeat rewrite determinant_aire.
apply aire_ordre_cycle.
Qed.

Lemma determinant_aire_triangle :
 forall A B C : PO,
 aire_triangle A B C = / 2 * Rabs (det (vec A B) (vec A C)).
unfold aire_triangle in |- *; intros.
repeat rewrite determinant_aire; auto.
Qed.

Lemma calcul_distance_droite :
 forall A B C : PO,
 A <> B ->
 distance_droite C (droite A B) =
 Rabs (det (vec A B) (vec A C)) / distance A B.
intros A B C H0; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := C);
 [ intros H H1; try clear existence_projete_orthogonal; try exact H1 | auto ].
repeat rewrite determinant_aire.
rewrite (distance_droite_def (A:=A) (B:=B) (C:=C) (H:=H)); auto.
rewrite (aire_avec_projete (A:=A) (B:=B) (C:=C) (H:=H)); auto.
replace (distance C H) with (distance H C); auto with geo.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
rewrite aire_orthogonal; auto with geo.
unfold Rdiv in |- *.
cut (distance A B <> 0); intros; auto with geo.
RReplace (distance A B * distance H C * / distance A B)
 (distance A B * / distance A B * distance H C).
RReplace (distance A B * / distance A B) 1.
ring.
Qed.


Require Import VST.floyd.proofauto.
Require Import Core.Core Core.Notations.

Open Scope IntScope.

Fixpoint required_size_loop n z l :=
  match n with
  | O => l
  | S n => if z >> (Int.repr l) * (Int.repr 8) == 0
          then l
          else required_size_loop n z (l + 1)%Z
  end.

Definition required_size z := required_size_loop 3%nat z 1%Z.

Lemma required_size_spec:
         forall l : int, forall i : Z,
           i = 1%Z \/ i = 2 \/ i = 3 \/ i = 4 ->
           (forall j : Z, 0 <= j < i ->
               (l >> (Int.repr j) * (Int.repr 8)) == 0 = false) ->
                 l >> (Int.repr i) * (Int.repr 8) = 0 ->
           required_size l = i.
Proof.
  intros l i N B SH.
  repeat break_or_hyp.
  * unfold required_size.
      cbn in *.
      rewrite SH.
      replace (0 == 0) with true by reflexivity;
      auto.
  * unfold required_size.
      cbn.
    do 1 erewrite B.
    autorewrite with norm in *.
    cbn in *.
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    normalize.
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
     autorewrite with norm in *;
    cbn in *;
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    all: normalize;
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
    erewrite B.
    all: nia.
Qed.

Fixpoint serialize_length_loop i n l :=
  match n with
  | O => []
  | S n =>
    Int.zero_ext 8 (l >> i) :: serialize_length_loop (i - Int.repr 8) n l
  end.

Definition serialize_length l :=
  let s := required_size l in
  let n := Z.to_nat s in
  (Int.repr 128 or (Int.repr s)) :: serialize_length_loop (Int.repr ((s - 1) * 8)) n l.

Fixpoint serialize_length_loop_app s n l :=
  match n with
  | O => []
  | S n =>
     serialize_length_loop_app (s + 1)%Z n l
                               ++ [Int.zero_ext 8 (l >> Int.repr (s * 8))]
  end.

Definition serialize_length_app l :=
  let s := required_size l in
  let n := Z.to_nat s in
  (Int.zero_ext 8 (Int.repr 128 or (Int.repr s))) :: serialize_length_loop_app 0%Z n l.

Lemma loop_len_req_size : forall n l i,
    len (serialize_length_loop_app i n l) = Z.of_nat n.
Proof.
  induction n; intros.
  - reflexivity.
  - simpl.
    erewrite Zlength_app.
    erewrite IHn.
    cbn.
    nia.
Qed.

Open Scope Z.

Lemma req_size_32 : forall l, 1 <= required_size l <= 4.
Proof.
  intros.
  unfold required_size.
  cbn.
  repeat break_if; autorewrite with norm; nia.
Qed.

Require Import ExtLib.Structures.Monad Types.

Definition length_serialize len size : errW1 asn_enc_rval :=
   if (127 >=? Int.signed len)%Z then
    if eq_dec size 0%int
    then raise (CustomError DWT_Error)
    else tell1 [Int.zero_ext 8 len] ;; ret (encode 1%Z)
  else let r := required_size len in
       if (r <? Int.unsigned size)%Z
       then tell1 (serialize_length_app len) ;; ret (encode (r + 1)%Z)
       else raise (CustomError DWT_Error).

Lemma length_serialize_req_size : forall l s ls z,
    length_serialize l s [] = inr (ls, encode z) ->
    len ls = z.
Proof.
intros until z.
unfold length_serialize.
repeat break_if; auto; try nia.
intros.
discriminate.
cbn.
intros.
inversion H.
auto.
pose proof (req_size_32 l).
unfold serialize_length_app.
autorewrite with sublist list.
intros.
inversion H0.
autorewrite with sublist list.
erewrite  loop_len_req_size .
erewrite Z2Nat.id; try nia.
intro.
discriminate.
Qed.
(*
Lemma length_serialize_req_size_gt0 : forall l s,
    snd (length_serialize l s) <> -1 -> 0 < snd (length_serialize l s).
Proof.
intros l s.
unfold length_serialize.
repeat break_if; auto; unfold snd in *; try nia.
pose proof (req_size_32 l).
nia.
Qed.

Lemma shr_lt_zero_32:
  forall x, Int.shr x (Int.repr (Int.zwordsize))
       = if Int.lt x Int.zero then Int.mone else Int.zero.
Proof.
  intros. apply Int.same_bits_eq; intros.
  rewrite Int.bits_shr; auto.
  rewrite Int.unsigned_repr.
  transitivity (Int.testbit x (Int.zwordsize - 1)).
  f_equal. destruct (zlt (i + (Int.zwordsize)) Int.zwordsize); try omega.
  rewrite Int.sign_bit_of_unsigned.
  unfold Int.lt. rewrite Int.signed_zero. unfold Int.signed.
  destruct (zlt (Int.unsigned x) Int.half_modulus).
  rewrite zlt_false. rewrite Int.bits_zero; auto.
  generalize (Int.unsigned_range x); omega.
  rewrite zlt_true. rewrite Int.bits_mone; auto.
  generalize (Int.unsigned_range x); omega.
  generalize Int.wordsize_max_unsigned; omega.
Qed.
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.
Require Import DoubleAdd.
Require Import DoubleSub.
Require Import DoubleMul.
Require Import DoubleSqrt.
Require Import DoubleLift.
Require Import DoubleDivn1.
Require Import DoubleDiv.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section Z_2nZ.

 Context {t : Type}{ops : ZnZ.Ops t}.

 Let w_digits      := ZnZ.digits.
 Let w_zdigits      := ZnZ.zdigits.

 Let w_to_Z        := ZnZ.to_Z.
 Let w_of_pos      := ZnZ.of_pos.
 Let w_head0       := ZnZ.head0.
 Let w_tail0       := ZnZ.tail0.

 Let w_0            := ZnZ.zero.
 Let w_1            := ZnZ.one.
 Let w_Bm1          := ZnZ.minus_one.

 Let w_compare     := ZnZ.compare.
 Let w_eq0         := ZnZ.eq0.

 Let w_opp_c       := ZnZ.opp_c.
 Let w_opp         := ZnZ.opp.
 Let w_opp_carry   := ZnZ.opp_carry.

 Let w_succ_c      := ZnZ.succ_c.
 Let w_add_c       := ZnZ.add_c.
 Let w_add_carry_c := ZnZ.add_carry_c.
 Let w_succ        := ZnZ.succ.
 Let w_add         := ZnZ.add.
 Let w_add_carry   := ZnZ.add_carry.

 Let w_pred_c      := ZnZ.pred_c.
 Let w_sub_c       := ZnZ.sub_c.
 Let w_sub_carry_c := ZnZ.sub_carry_c.
 Let w_pred        := ZnZ.pred.
 Let w_sub         := ZnZ.sub.
 Let w_sub_carry   := ZnZ.sub_carry.

 Let w_mul_c       := ZnZ.mul_c.
 Let w_mul         := ZnZ.mul.
 Let w_square_c    := ZnZ.square_c.

 Let w_div21       := ZnZ.div21.
 Let w_div_gt      := ZnZ.div_gt.
 Let w_div         := ZnZ.div.

 Let w_mod_gt      := ZnZ.modulo_gt.
 Let w_mod         := ZnZ.modulo.

 Let w_gcd_gt      := ZnZ.gcd_gt.
 Let w_gcd         := ZnZ.gcd.

 Let w_add_mul_div := ZnZ.add_mul_div.

 Let w_pos_mod := ZnZ.pos_mod.

 Let w_is_even     := ZnZ.is_even.
 Let w_sqrt2       := ZnZ.sqrt2.
 Let w_sqrt        := ZnZ.sqrt.

 Let _zn2z := zn2z t.

 Let wB := base w_digits.

 Let w_Bm2 := w_pred w_Bm1.

 Let ww_1 := ww_1 w_0 w_1.
 Let ww_Bm1 := ww_Bm1 w_Bm1.

 Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end.

 Let _ww_digits := xO w_digits.

 Let _ww_zdigits := w_add2 w_zdigits w_zdigits.

 Let to_Z := zn2z_to_Z wB w_to_Z.

 Let w_W0 := ZnZ.WO.
 Let w_0W := ZnZ.OW.
 Let w_WW := ZnZ.WW.

 Let ww_of_pos p :=
  match w_of_pos p with
  | (N0, l) => (N0, WW w_0 l)
  | (Npos ph,l) =>
    let (n,h) := w_of_pos ph in (n, w_WW h l)
  end.

 Let head0 :=
  Eval lazy beta delta [ww_head0] in
  ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits.

 Let tail0 :=
  Eval lazy beta delta [ww_tail0] in
  ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits.

 Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t).
 Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t).
 Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t).

 (* ** Comparison ** *)
 Let compare :=
  Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare.

 Let eq0 (x:zn2z t) :=
  match x with
  | W0 => true
  | _ => false
  end.

 (* ** Opposites ** *)
 Let opp_c :=
  Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry.

 Let opp :=
  Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp.

 Let opp_carry :=
  Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry.

 (* ** Additions ** *)

 Let succ_c :=
  Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c.

 Let add_c :=
  Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c.

 Let add_carry_c :=
  Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in
  ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c.

 Let succ :=
  Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ.

 Let add :=
  Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry.

 Let add_carry :=
  Eval lazy beta iota delta [ww_add_carry ww_succ] in
  ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry.

 (* ** Subtractions ** *)

 Let pred_c :=
  Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c.

 Let sub_c :=
  Eval lazy beta iota delta [ww_sub_c ww_opp_c] in
  ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c.

 Let sub_carry_c :=
  Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in
  ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c.

 Let pred :=
  Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred.

 Let sub :=
  Eval lazy beta iota delta [ww_sub ww_opp] in
  ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.

 Let sub_carry :=
  Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in
  ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred
  w_sub w_sub_carry.

 (* ** Multiplication ** *)

 Let mul_c :=
  Eval lazy beta iota delta [ww_mul_c double_mul_c] in
  ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry.

 Let karatsuba_c :=
  Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in
  ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c
    add_c add add_carry sub_c sub.

 Let mul :=
  Eval lazy beta delta [ww_mul] in
  ww_mul w_W0 w_add w_mul_c w_mul add.

 Let square_c :=
  Eval lazy beta delta [ww_square_c] in
  ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry.

 (* Division operation *)

 Let div32 :=
   Eval lazy beta iota delta [w_div32] in
   w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c.

 Let div21 :=
  Eval lazy beta iota delta [ww_div21] in
   ww_div21 w_0 w_0W div32 ww_1 compare sub.

 Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end.

 Let add_mul_div :=
  Eval lazy beta delta [ww_add_mul_div] in
  ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low.

 Let div_gt :=
  Eval lazy beta delta [ww_div_gt] in
  ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp
  w_opp_carry w_sub_c w_sub w_sub_carry
  w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits.

 Let div :=
  Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt.

 Let mod_gt :=
  Eval lazy beta delta [ww_mod_gt] in
  ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry
  w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits.

 Let mod_ :=
  Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt.

 Let pos_mod :=
  Eval lazy beta delta [ww_pos_mod] in
    ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits.

 Let is_even :=
  Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even.

 Let sqrt2 :=
  Eval lazy beta delta [ww_sqrt2] in
    ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c
    w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c
    pred add_c add sub_c add_mul_div.

 Let sqrt :=
  Eval lazy beta delta [ww_sqrt] in
    ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits
     _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low.

 Let gcd_gt_fix :=
  Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in
  ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry
      w_sub_c w_sub w_sub_carry w_gcd_gt
      w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div
      w_zdigits.

 Let gcd_cont :=
  Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare.

 Let gcd_gt :=
  Eval lazy beta delta [ww_gcd_gt] in
  ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.

 Let gcd :=
  Eval lazy beta delta [ww_gcd] in
  ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.

 (* ** Record of operators on 2 words *)

 Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) :=
  ZnZ.MkOps _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    mul_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt.

 Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) :=
   ZnZ.MkOps _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    karatsuba_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt.

 (* Proof *)
 Context {specs : ZnZ.Specs ops}.

 Hint Resolve
    ZnZ.spec_to_Z
    ZnZ.spec_of_pos
    ZnZ.spec_0
    ZnZ.spec_1
    ZnZ.spec_m1
    ZnZ.spec_compare
    ZnZ.spec_eq0
    ZnZ.spec_opp_c
    ZnZ.spec_opp
    ZnZ.spec_opp_carry
    ZnZ.spec_succ_c
    ZnZ.spec_add_c
    ZnZ.spec_add_carry_c
    ZnZ.spec_succ
    ZnZ.spec_add
    ZnZ.spec_add_carry
    ZnZ.spec_pred_c
    ZnZ.spec_sub_c
    ZnZ.spec_sub_carry_c
    ZnZ.spec_pred
    ZnZ.spec_sub
    ZnZ.spec_sub_carry
    ZnZ.spec_mul_c
    ZnZ.spec_mul
    ZnZ.spec_square_c
    ZnZ.spec_div21
    ZnZ.spec_div_gt
    ZnZ.spec_div
    ZnZ.spec_modulo_gt
    ZnZ.spec_modulo
    ZnZ.spec_gcd_gt
    ZnZ.spec_gcd
    ZnZ.spec_head0
    ZnZ.spec_tail0
    ZnZ.spec_add_mul_div
    ZnZ.spec_pos_mod
    ZnZ.spec_is_even
    ZnZ.spec_sqrt2
    ZnZ.spec_sqrt
    ZnZ.spec_WO
    ZnZ.spec_OW
    ZnZ.spec_WW.

 Ltac wwauto := unfold ww_to_Z; auto.

 Let wwB := base _ww_digits.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Notation "[+| c |]" :=
   (interp_carry 1 wwB to_Z c)  (at level 0, x at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wwB to_Z c)  (at level 0, x at level 99).

 Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x)  (at level 0, x at level 99).

 Let spec_ww_to_Z   : forall x, 0 <= [| x |] < wwB.
 Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed.

 Let spec_ww_of_pos : forall p,
     Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
 Proof.
  unfold ww_of_pos;intros.
  rewrite (ZnZ.spec_of_pos p). unfold w_of_pos.
  case (ZnZ.of_pos p); intros. simpl.
  destruct n; simpl ZnZ.to_Z.
  simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial.
  unfold Z_of_N.
  rewrite (ZnZ.spec_of_pos p0).
  case (ZnZ.of_pos p0); intros. simpl.
  unfold fst, snd,Z_of_N, to_Z, wB, w_digits, w_to_Z, w_WW.
  rewrite ZnZ.spec_WW.
  replace wwB with (wB*wB).
  unfold wB,w_to_Z,w_digits;destruct n;ring.
  symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits).
 Qed.

 Let spec_ww_0 : [|W0|] = 0.
 Proof. reflexivity. Qed.

 Let spec_ww_1 : [|ww_1|] = 1.
 Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed.

 Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1.
 Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.

 Let spec_ww_compare :
  forall x y, compare x y = Zcompare [|x|] [|y|].
 Proof.
  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto.
 Qed.

 Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0.
 Proof. destruct x;simpl;intros;trivial;discriminate. Qed.

 Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|].
 Proof.
  refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _);
  auto.
 Qed.

 Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB.
 Proof.
  refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp
   w_digits w_to_Z _ _ _ _ _);
  auto.
 Qed.

 Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1.
 Proof.
  refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _);
  wwauto.
 Qed.

 Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
 Proof.
  refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|].
 Proof.
  refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto.
 Qed.

 Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1.
 Proof.
  refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c
   w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB.
 Proof.
  refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB.
 Proof.
  refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB.
 Proof.
  refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ
  w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
 Proof.
  refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z
   _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
 Proof.
  refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c
   w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1.
 Proof.
  refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB.
 Proof.
  refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z
   _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB.
 Proof.
  refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp
   w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB.
 Proof.
  refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|].
 Proof.
  refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits
   w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|].
 Proof.
 refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
          _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
  unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto.
 Qed.

 Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB.
 Proof.
  refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|].
 Proof.
  refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add
   add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_w_div32 : forall a1 a2 a3 b1 b2,
       wB / 2 <= (w_to_Z b1) ->
       [|WW a1 a2|] < [|WW b1 b2|] ->
       let (q, r) := div32 a1 a2 a3 b1 b2 in
       (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) =
       (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\
       0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2.
 Proof.
  refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z
   _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  unfold w_Bm2, w_to_Z, w_pred, w_Bm1.
  rewrite ZnZ.spec_pred, ZnZ.spec_m1.
  unfold w_digits;rewrite Zmod_small. ring.
  assert (H:= wB_pos(ZnZ.digits)). omega.
  exact ZnZ.spec_div21.
 Qed.

 Let spec_ww_div21 : forall a1 a2 b,
      wwB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := div21 a1 a2 b in
      [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z
   _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_add2: forall x y,
  [|w_add2 x y|] = w_to_Z x + w_to_Z y.
  unfold w_add2.
  intros xh xl; generalize (ZnZ.spec_add_c xh xl).
  unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z.
    intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0.
  unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith.
  intros w0; rewrite Zmult_1_l; simpl.
  unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith.
  rewrite Zmult_1_l; auto.
 Qed.

 Let spec_low: forall x,
  w_to_Z (low x) = [|x|] mod wB.
  intros x; case x; simpl low.
    unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; auto.
  intros xh xl; simpl.
  rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  unfold wB, base; auto with zarith.
 Qed.

 Let spec_ww_digits:
  [|_ww_zdigits|] = Zpos (xO w_digits).
 Proof.
 unfold w_to_Z, _ww_zdigits.
 rewrite spec_add2.
 unfold w_to_Z, w_zdigits, w_digits.
 rewrite ZnZ.spec_zdigits; auto.
 rewrite Zpos_xO; auto with zarith.
 Qed.

 Let spec_ww_head00  : forall x,  [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_head00 w_0 w_0W
                w_compare w_head0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto.
 exact ZnZ.spec_head00.
 exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_head0  : forall x,  0 < [|x|] ->
	 wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB.
 Proof.
  refine (spec_ww_head0 w_0 w_0W w_compare w_head0
           w_add2 w_zdigits _ww_zdigits
   w_to_Z _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_tail00  : forall x,  [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_tail00 w_0 w_0W
                w_compare w_tail0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto.
 exact ZnZ.spec_tail00.
 exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_tail0  : forall x,  0 < [|x|] ->
  exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|].
 Proof.
  refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0
           w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Lemma spec_ww_add_mul_div : forall x y p,
       [|p|] <= Zpos _ww_digits ->
       [| add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB.
 Proof.
 refine (@spec_ww_add_mul_div t w_0 w_WW w_W0 w_0W compare w_add_mul_div
              sub w_digits w_zdigits low w_to_Z
           _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
 Qed.

 Let spec_ww_div_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|].
 Proof.
refine
(@spec_ww_div_gt t w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
).
  exact ZnZ.spec_0.
  exact ZnZ.spec_to_Z.
  wwauto.
  wwauto.
  exact ZnZ.spec_compare.
  exact ZnZ.spec_eq0.
  exact ZnZ.spec_opp_c.
  exact ZnZ.spec_opp.
  exact ZnZ.spec_opp_carry.
  exact ZnZ.spec_sub_c.
  exact ZnZ.spec_sub.
  exact ZnZ.spec_sub_carry.
  exact ZnZ.spec_div_gt.
  exact ZnZ.spec_add_mul_div.
  exact ZnZ.spec_head0.
  exact ZnZ.spec_div21.
  exact spec_w_div32.
  exact ZnZ.spec_zdigits.
  exact spec_ww_digits.
  exact spec_ww_1.
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_div : forall a b, 0 < [|b|] ->
      let (q,r) := div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_mod_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      [|mod_gt a b|] = [|a|] mod [|b|].
 Proof.
  refine (@spec_ww_mod_gt t w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div
   w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_div_gt.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_mod :  forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|].
 Proof.
  refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto.
 Qed.

 Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
 Proof.
  refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _
    w_0 w_0 w_eq0 w_gcd_gt _ww_digits
  _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
   _ _);auto.
 Qed.

 Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
 Proof.
  refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt
  _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
  refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact ZnZ.spec_div21.
  exact ZnZ.spec_zdigits.
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
   _ _);auto.
 Qed.

 Let spec_ww_is_even : forall x,
      match is_even x with
         true => [|x|] mod 2 = 0
      | false => [|x|] mod 2 = 1
      end.
 Proof.
 refine (@spec_ww_is_even t w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto.
 exact ZnZ.spec_is_even.
 Qed.

 Let spec_ww_sqrt2 : forall x y,
       wwB/ 4 <= [|x|] ->
       let (s,r) := sqrt2 x y in
          [[WW x y]] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|].
 Proof.
 intros x y H.
 refine (@spec_ww_sqrt2 t w_is_even w_compare w_0 w_1 w_Bm1
               w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits
               _ww_zdigits
               w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div
                _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact ZnZ.spec_zdigits.
 exact ZnZ.spec_more_than_1_digit.
 exact ZnZ.spec_is_even.
 exact ZnZ.spec_div21.
 exact spec_ww_add_mul_div.
 exact ZnZ.spec_sqrt2.
 Qed.

 Let spec_ww_sqrt : forall x,
       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
 Proof.
 refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1
           w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
               w_sqrt2 pred add_mul_div head0 compare
            _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact ZnZ.spec_zdigits.
 exact ZnZ.spec_more_than_1_digit.
 exact ZnZ.spec_is_even.
 exact spec_ww_add_mul_div.
 exact ZnZ.spec_sqrt2.
 Qed.

 Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops.
 Proof.
  apply ZnZ.MkSpecs; auto.
  exact spec_ww_add_mul_div.

  refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
  unfold w_to_Z, w_zdigits.
  rewrite ZnZ.spec_zdigits.
  rewrite <- Zpos_xO; exact spec_ww_digits.
 Qed.

 Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba.
 Proof.
  apply ZnZ.MkSpecs; auto.
  exact spec_ww_add_mul_div.
  refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact ZnZ.spec_zdigits.
  unfold w_to_Z, w_zdigits.
  rewrite ZnZ.spec_zdigits.
  rewrite <- Zpos_xO; exact spec_ww_digits.
 Qed.

End Z_2nZ.

Section MulAdd.

  Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}.

  Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c.

  Notation "[| x |]" := (ZnZ.to_Z x)  (at level 0, x at level 99).

  Notation "[|| x ||]" :=
   (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x)  (at level 0, x at level 99).

  Lemma spec_mul_add: forall x y z,
     let (zh, zl) := mul_add x y z in
  [||WW zh zl||] = [|x|] * [|y|] + [|z|].
  Proof.
  intros x y z.
   refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto.
  exact ZnZ.spec_0.
  exact ZnZ.spec_to_Z.
  exact ZnZ.spec_succ.
  exact ZnZ.spec_add_c.
  exact ZnZ.spec_mul_c.
  Qed.

End MulAdd.

(** Modular versions of DoubleCyclic *)

Module DoubleCyclic (C:CyclicType) <: CyclicType.
 Definition t := zn2z C.t.
 Instance ops : ZnZ.Ops t := mk_zn2z_ops.
 Instance specs : ZnZ.Specs ops := mk_zn2z_specs.
End DoubleCyclic.

Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType.
 Definition t := zn2z C.t.
 Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba.
 Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba.
End DoubleCyclicKaratsuba.


Require Import
        Fiat.Common.BoundedLookup.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.Vectors.Vector
        Bedrock.Word.

Section Enum.
  Context {len : nat}.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Context {sz : nat}.
  Context {ta : t A (S len)}.
  Variable (tb : t (word sz) (S len)).

  Inductive NoDupVector {A}
    : forall {n}, Vector.t A n -> Prop :=
    NoDupVector_nil : NoDupVector (Vector.nil _)
  | NoDupVector_cons : forall (x : A) {n} (l : Vector.t A n),
      ~ Vector.In x l -> NoDupVector l -> NoDupVector (Vector.cons _ x _ l).

  Lemma NoDupVector_invert {A'}
    : forall n (l : Vector.t A' n),
      NoDupVector l
      -> match l with
         | Vector.nil => True
         | Vector.cons a _ l' =>
           ~ Vector.In a l' /\ NoDupVector l'
         end.
  Proof.
    clear; induction 1; eauto.
  Qed.

  Definition format_enum (idx : Fin.t _) :
    CacheFormat -> Comp (B * CacheFormat) :=
    format_word (nth tb idx).

  Definition encode_enum (idx : Fin.t _) :
    CacheFormat -> B * CacheFormat :=
    encode_word (nth tb idx).

  Lemma refine_format_enum :
    forall idx ce,
      refine (format_enum idx ce)
             (ret (encode_enum idx ce)).
  Proof.
    intros; reflexivity.
  Qed.

  Fixpoint word_indexed {n : nat}
           (w : word sz)
           (t : t (word sz) n) : option (Fin.t n)
    := match t in Vector.t _ n return option (Fin.t n) with
       | nil => None
       | cons w' _ t' =>
         if (weqb w w') then Some (Fin.F1) else
           match word_indexed w t' with
           | Some f => Some (Fin.FS f)
           | None => None
           end
       end.

  Definition decode_enum (b : B)
             (cd : CacheDecode)
    : option (Fin.t _ * B * CacheDecode) :=
    `(w, b', cd') <- decode_word (sz:=sz) b cd;
      Ifopt word_indexed w tb as idx Then
      Some (idx, b', cd')
      Else None.

  Lemma word_indexed_correct :
    forall n (i : Fin.t n) (t : t (word sz) n),
      NoDupVector t
      -> match word_indexed (nth t i) t with
      | Some w' => i = w'
      | None => False
      end.
  Proof.
    clear.
    induction i.
    - intro; pattern n, t; apply Vector.caseS; simpl; intros.
      rewrite (proj2 (weqb_true_iff h h)); eauto.
    - intro; generalize i (IHi (Vector.tl t)); clear.
      pattern n, t; apply Vector.caseS; simpl.
      intros h n0 t0 i; case_eq (word_indexed (nth t0 i) t0); intros;
        apply NoDupVector_invert in H1; intuition subst.
      case_eq (weqb (nth t0 t1) h); intros; eauto.
      apply weqb_true_iff in H0; subst.
      destruct H2; generalize t0 H; clear; induction t1.
      + intro; pattern n, t0; apply Vector.caseS; simpl; intros; econstructor.
      + intro; revert t1 IHt1; pattern n, t0; apply Vector.caseS;
          simpl; intros.
        case_eq (weqb (nth t t1) h); intros; eauto.
        * apply weqb_true_iff in H0; subst; econstructor.
        * rewrite H0 in H.
          econstructor 2; apply IHt1.
          destruct (word_indexed (nth t t1) t); try discriminate.
          f_equal; apply Fin.FS_inj; congruence.
  Qed.

  Lemma word_indexed_correct':
    forall n (v : Fin.t n) (w : word sz) (t : t (word sz) n),
      word_indexed w t = Some v -> w = nth t v.
  Proof.
    clear.
    induction v.
    - intros w tb; pattern n, tb;
        eapply Vector.caseS; simpl.
      intros; destruct (weqb w h) eqn: ?.
      eapply weqb_true_iff; eauto.
      destruct ( word_indexed w t); try discriminate.
    - intros w tb.
      revert w v IHv.
      pattern n, tb; eapply Vector.rectS; simpl; intros.
      inversion v.
      intros; destruct (weqb w a) eqn: ?.
      discriminate.
      destruct (word_indexed w v) eqn : ? ; try discriminate.
      eapply IHv.
      rewrite Heqo.
      f_equal.
      eapply Fin.FS_inj.
      congruence.
  Qed.

  Theorem Enum_decode_correct
          (tb_OK : NoDupVector tb)
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    : CorrectDecoder monoid (fun _ => True)
                     (fun _ => True) eq format_enum decode_enum P
                     format_enum.
  Proof.
    apply_bijection_rule' with (fun w => word_indexed w tb);
      intuition eauto using Word_decode_correct.
    eapply word_indexed_correct in tb_OK.
    destruct word_indexed eqn:?; subst; intuition eauto.
    symmetry. eauto using word_indexed_correct'.

    derive_decoder_equiv; rewrite Heqo0; intuition eauto.
  Qed.
End Enum.

Lemma VectorIn_cons {A} {n}
  : forall (v : Vector.t A n) a a',
    Vector.In a' (Vector.cons _ a _ v) -> a = a' \/ Vector.In a' v.
Proof.
  intros; inversion H; subst; eauto.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma forall_Vector_P {A} (P : A -> Prop) {n}
  : forall v : Vector.t A n,
    Vector.Forall P v
    -> forall idx, P (Vector.nth v idx).
Proof.
  induction v; simpl; intros.
  - inversion idx.
  - revert v IHv H; pattern n, idx; apply Fin.caseS; simpl;
      intros; inversion H; subst; eauto.
    eapply IHv.
    apply Eqdep_dec.inj_pair2_eq_dec in H2; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Ltac Discharge_NoDupVector :=
  match goal with
  |- NoDupVector _ =>
  repeat econstructor; intro;
  repeat match goal with
         | H : Vector.In _ _ |- _ =>
           first [apply VectorIn_cons in H; destruct H; try discriminate
                 | inversion H]
         end
  end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Proofs of specification for functions defined over Vector

   Author: Pierre Boutillier
   Institution: PPS, INRIA 12/2010
*)

Require Fin.
Require Import VectorDef.
Import VectorNotations.

(** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all
is true for the one that use [lt] *)

Lemma eq_nth_iff A n (v1 v2: t A n):
  (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2.
Proof.
split.
  revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros.
    reflexivity.
    f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl).
    apply H. intros p1 p2 H1;
    apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)).
  intros; now f_equal.
Qed.

Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n),
 nth_order v H = last v.
Proof.
unfold nth_order; refine (@rectS _ _ _ _); now simpl.
Qed.

Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2):
  nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2.
Proof.
subst k2; induction k1.
  generalize dependent n. apply caseS ; intros. now simpl.
  generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl.
Qed.

Lemma shiftin_last A a n (v: t A n): last (shiftin a v) = a.
Proof.
induction v ;now simpl.
Qed.

Lemma shiftrepeat_nth A: forall n k (v: t A (S n)),
  nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k.
Proof.
refine (@Fin.rectS _ _ _); intros.
  revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t.
  revert p H.
  refine (match v as v' in t _ m return match m as m' return t A m' -> Type with
    |S (S n) => fun v => forall p : Fin.t (S n),
      (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) ->
      (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p]
    |_ => fun _ => @ID end v' with
  |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl.
Qed.

Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v.
Proof.
refine (@rectS _ _ _ _); now simpl.
Qed.

Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a.
Proof.
now induction p.
Qed.

Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2):
  (map f v) [@ p1] = f (v [@ p2]).
Proof.
subst p2; induction p1.
  revert n v; refine (@caseS _ _ _); now simpl.
  revert n v p1 IHp1; refine (@caseS _  _ _); now simpl.
Qed.

Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n):
  p1 = p2 -> p2 = p3 -> (map2 f v w) [@p1] = f (v[@p2]) (w[@p3]).
Proof.
intros; subst p2; subst p3; revert n v w p1.
refine (@rect2 _ _ _ _ _); simpl.
  exact (Fin.case0 _).
  intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _);
    now simpl.
Qed.

Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A}
  (assoc: forall a b c, f (f a b) c = f (f a c) b)
  {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a.
Proof.
assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h).
  induction v0.
    now simpl.
    intros; simpl. rewrite<- IHv0. now f_equal.
  induction v.
    reflexivity.
    simpl. intros; now rewrite<- (IHv).
Qed.

Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l.
Proof.
induction l.
  reflexivity.
  unfold to_list; simpl. now f_equal.
Qed.