From stdpp Require Export prelude.
From bunched.algebra Require Export notation.
Set Primitive Projections.

Section bi_mixin.
  Context {PROP : Type} {bi_equiv : Equiv PROP}.
  Context (bi_entails : PROP → PROP → Prop).
  Context (bi_emp : PROP).
  Context (bi_pure : Prop → PROP).
  Context (bi_and : PROP → PROP → PROP).
  Context (bi_or : PROP → PROP → PROP).
  Context (bi_impl : PROP → PROP → PROP).
  Context (bi_forall : ∀ A, (A → PROP) → PROP).
  Context (bi_exist : ∀ A, (A → PROP) → PROP).
  Context (bi_sep : PROP → PROP → PROP).
  Context (bi_wand : PROP → PROP → PROP).

  Bind Scope bi_scope with PROP.
  Local Infix "⊢" := bi_entails.
  Local Notation "'emp'" := bi_emp : bi_scope.
  Local Notation "'True'" := (bi_pure True) : bi_scope.
  Local Notation "'False'" := (bi_pure False) : bi_scope.
  Local Notation "'⌜' φ '⌝'" := (bi_pure φ%type%stdpp) : bi_scope.
  Local Infix "∧" := bi_and : bi_scope.
  Local Infix "∨" := bi_or : bi_scope.
  Local Infix "→" := bi_impl : bi_scope.
  Local Notation "∀ x .. y , P" :=
    (bi_forall _ (λ x, .. (bi_forall _ (λ y, P%I)) ..)) : bi_scope.
  Local Notation "∃ x .. y , P" :=
    (bi_exist _ (λ x, .. (bi_exist _ (λ y, P%I)) ..)) : bi_scope.
  Local Infix "∗" := bi_sep : bi_scope.
  Local Infix "-∗" := bi_wand : bi_scope.

  (** * Axioms for a general BI (logic of bunched implications) *)

  (** The following axioms are satisifed by both affine and linear BIs, and BIs
  that combine both kinds of resources. In particular, we have an "ordered RA"
  model satisfying all these axioms. For this model, we extend RAs with an
  arbitrary partial order, and up-close resources wrt. that order (instead of
  extension order).  We demand composition to be monotone wrt. the order: [x1 ≼
  x2 → x1 ⋅ y ≼ x2 ⋅ y].  We define [emp := λ r, ε ≼ r]; persistently is still
  defined with the core: [persistently P := λ r, P (core r)].  This is uplcosed
  because the core is monotone.  *)

  Record BiMixin := {
    bi_mixin_entails_po : PreOrder bi_entails;
    bi_mixin_equiv_equivalence : Equivalence bi_equiv;
    bi_mixin_equiv_entails P Q : (P ≡ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P);

    (** Setoid stuff *)
    bi_mixin_pure_ne  : Proper (iff ==> (≡)) bi_pure;
    bi_mixin_and_ne : Proper ((≡) ==> (≡) ==> (≡)) bi_and;
    bi_mixin_or_ne : Proper ((≡) ==> (≡) ==> (≡)) bi_or;
    bi_mixin_impl_ne : Proper ((≡) ==> (≡) ==> (≡)) bi_impl;
    bi_mixin_forall_ne A  :
      Proper (pointwise_relation _ (≡) ==> (≡)) (bi_forall A);
    bi_mixin_exist_ne A :
      Proper (pointwise_relation _ (≡) ==> (≡)) (bi_exist A);
    bi_mixin_sep_ne : Proper ((≡) ==> (≡) ==> (≡)) bi_sep;
    bi_mixin_wand_ne : Proper ((≡) ==> (≡) ==> (≡)) bi_wand;

    (** Higher-order logic *)
    bi_mixin_pure_intro (φ : Prop) P : φ → P ⊢ ⌜ φ ⌝;
    bi_mixin_pure_elim' (φ : Prop) P : (φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P;

    bi_mixin_and_elim_l P Q : P ∧ Q ⊢ P;
    bi_mixin_and_elim_r P Q : P ∧ Q ⊢ Q;
    bi_mixin_and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R;

    bi_mixin_or_intro_l P Q : P ⊢ P ∨ Q;
    bi_mixin_or_intro_r P Q : Q ⊢ P ∨ Q;
    bi_mixin_or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R;

    bi_mixin_impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R;
    bi_mixin_impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R;

    bi_mixin_forall_intro {A} P (Ψ : A → PROP) : (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a;
    bi_mixin_forall_elim {A} {Ψ : A → PROP} a : (∀ a, Ψ a) ⊢ Ψ a;

    bi_mixin_exist_intro {A} {Ψ : A → PROP} a : Ψ a ⊢ ∃ a, Ψ a;
    bi_mixin_exist_elim {A} (Φ : A → PROP) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q;

    (** BI connectives *)
    bi_mixin_sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q';
    bi_mixin_emp_sep_1 P : P ⊢ emp ∗ P;
    bi_mixin_emp_sep_2 P : emp ∗ P ⊢ P;
    bi_mixin_sep_comm' P Q : P ∗ Q ⊢ Q ∗ P;
    bi_mixin_sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R);
    bi_mixin_wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R;
    bi_mixin_wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R;

  }.

End bi_mixin.

Structure bi := Bi {
  bi_car :> Type;
  bi_equiv : Equiv bi_car;
  bi_entails : bi_car → bi_car → Prop;
  bi_emp : bi_car;
  bi_pure : Prop → bi_car;
  bi_and : bi_car → bi_car → bi_car;
  bi_or : bi_car → bi_car → bi_car;
  bi_impl : bi_car → bi_car → bi_car;
  bi_forall : ∀ A, (A → bi_car) → bi_car;
  bi_exist : ∀ A, (A → bi_car) → bi_car;
  bi_sep : bi_car → bi_car → bi_car;
  bi_wand : bi_car → bi_car → bi_car;
  bi_bi_mixin : BiMixin bi_entails bi_emp bi_pure bi_and bi_or bi_impl bi_forall
                        bi_exist bi_sep bi_wand;
}.
Bind Scope bi_scope with bi_car.

Global Instance bi_equiv' (PROP : bi) : Equiv PROP := bi_equiv PROP.
Global Instance bi_equiv'_equivalence (PROP : bi) : Equivalence (≡@{PROP}).
Proof. eapply bi_mixin_equiv_equivalence, bi_bi_mixin. Defined.

Global Instance: Params (@bi_entails) 1 := {}.
Global Instance: Params (@bi_emp) 1 := {}.
Global Instance: Params (@bi_pure) 1 := {}.
Global Instance: Params (@bi_and) 1 := {}.
Global Instance: Params (@bi_or) 1 := {}.
Global Instance: Params (@bi_impl) 1 := {}.
Global Instance: Params (@bi_forall) 2 := {}.
Global Instance: Params (@bi_exist) 2 := {}.
Global Instance: Params (@bi_sep) 1 := {}.
Global Instance: Params (@bi_wand) 1 := {}.

Global Arguments bi_car : simpl never.
Global Arguments bi_equiv : simpl never.
Global Arguments bi_entails {PROP} _ _ : simpl never, rename.
Global Arguments bi_emp {PROP} : simpl never, rename.
Global Arguments bi_pure {PROP} _%stdpp : simpl never, rename.
Global Arguments bi_and {PROP} _ _ : simpl never, rename.
Global Arguments bi_or {PROP} _ _ : simpl never, rename.
Global Arguments bi_impl {PROP} _ _ : simpl never, rename.
Global Arguments bi_forall {PROP _} _%I : simpl never, rename.
Global Arguments bi_exist {PROP _} _%I : simpl never, rename.
Global Arguments bi_sep {PROP} _ _ : simpl never, rename.
Global Arguments bi_wand {PROP} _ _ : simpl never, rename.

Global Hint Extern 0 (bi_entails _ _) => reflexivity : core.
Global Instance bi_rewrite_relation (PROP : bi) : RewriteRelation (@bi_entails PROP) := {}.
Global Instance bi_inhabited {PROP : bi} : Inhabited PROP := populate (bi_pure True).

Notation "P ⊢ Q" := (bi_entails P%I Q%I) : stdpp_scope.
Notation "P '⊢@{' PROP } Q" := (bi_entails (PROP:=PROP) P%I Q%I) (only parsing) : stdpp_scope.
Notation "(⊢)" := bi_entails (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP } )" := (bi_entails (PROP:=PROP)) (only parsing) : stdpp_scope.

Notation "P ⊣⊢ Q" := (equiv (A:=bi_car _) P%I Q%I) : stdpp_scope.
Notation "P '⊣⊢@{' PROP } Q" := (equiv (A:=bi_car PROP) P%I Q%I) (only parsing) : stdpp_scope.
Notation "(⊣⊢)" := (equiv (A:=bi_car _)) (only parsing) : stdpp_scope.
Notation "'(⊣⊢@{' PROP } )" := (equiv (A:=bi_car PROP)) (only parsing) : stdpp_scope.
Notation "( P ⊣⊢.)" := (equiv (A:=bi_car _) P) (only parsing) : stdpp_scope.
Notation "(.⊣⊢ Q )" := (λ P, P ≡@{bi_car _} Q) (only parsing) : stdpp_scope.

Notation "P -∗ Q" := (P ⊢ Q) : stdpp_scope.

Notation "'emp'" := (bi_emp) : bi_scope.
Notation "'⌜' φ '⌝'" := (bi_pure φ%type%stdpp) : bi_scope.
Notation "'True'" := (bi_pure True) : bi_scope.
Notation "'False'" := (bi_pure False) : bi_scope.
Infix "∧" := bi_and : bi_scope.
Notation "(∧)" := bi_and (only parsing) : bi_scope.
Infix "∨" := bi_or : bi_scope.
Notation "(∨)" := bi_or (only parsing) : bi_scope.
Infix "→" := bi_impl : bi_scope.
Notation "¬ P" := (P → False)%I : bi_scope.
Infix "∗" := bi_sep : bi_scope.
Notation "(∗)" := bi_sep (only parsing) : bi_scope.
Notation "P -∗ Q" := (bi_wand P Q) : bi_scope.
Notation "∀ x .. y , P" :=
  (bi_forall (λ x, .. (bi_forall (λ y, P%I)) ..)) : bi_scope.
Notation "∃ x .. y , P" :=
  (bi_exist (λ x, .. (bi_exist (λ y, P%I)) ..)) : bi_scope.

Definition bi_emp_valid {PROP : bi} (P : PROP) : Prop := emp ⊢ P.

Global Arguments bi_emp_valid {_} _%I : simpl never.
Typeclasses Opaque bi_emp_valid.

Notation "⊢ Q" := (bi_emp_valid Q%I) : stdpp_scope.
Notation "'⊢@{' PROP } Q" := (bi_emp_valid (PROP:=PROP) Q%I) (only parsing) : stdpp_scope.
(** Work around parsing issues: see [notation.v] for details. *)
Notation "'(⊢@{' PROP } Q )" := (bi_emp_valid (PROP:=PROP) Q%I) (only parsing) : stdpp_scope.
Notation "(.⊢ Q )" := (λ P, P ⊢ Q) (only parsing) : stdpp_scope.
Notation "( P ⊢.)" := (bi_entails P) (only parsing) : stdpp_scope.

Module bi.
Section bi_laws.
Context {PROP : bi}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types A : Type.

(* About the entailment *)
Global Instance entails_po : PreOrder (@bi_entails PROP).
Proof. eapply bi_mixin_entails_po, bi_bi_mixin. Qed.
Lemma equiv_entails P Q : P ≡ Q ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof. eapply bi_mixin_equiv_entails, bi_bi_mixin. Qed.

(* Non-expansiveness *)
Global Instance pure_ne : Proper (iff ==> (≡)) (@bi_pure PROP).
Proof. eapply bi_mixin_pure_ne, bi_bi_mixin. Qed.
Global Instance and_ne : Proper ((≡) ==> (≡) ==> (≡)) (@bi_and PROP).
Proof. eapply bi_mixin_and_ne, bi_bi_mixin. Qed.
Global Instance or_ne : Proper ((≡) ==> (≡) ==> (≡)) (@bi_or PROP).
Proof. eapply bi_mixin_or_ne, bi_bi_mixin. Qed.
Global Instance impl_ne : Proper ((≡) ==> (≡) ==> (≡)) (@bi_impl PROP).
Proof. eapply bi_mixin_impl_ne, bi_bi_mixin. Qed.
Global Instance forall_ne A :
  Proper (pointwise_relation _ (≡) ==> (≡)) (@bi_forall PROP A).
Proof. eapply bi_mixin_forall_ne, bi_bi_mixin. Qed.
Global Instance exist_ne A :
  Proper (pointwise_relation _ ((≡)) ==> (≡)) (@bi_exist PROP A).
Proof. eapply bi_mixin_exist_ne, bi_bi_mixin. Qed.
Global Instance sep_ne : Proper ((≡) ==> (≡) ==> (≡)) (@bi_sep PROP).
Proof. eapply bi_mixin_sep_ne, bi_bi_mixin. Qed.
Global Instance wand_ne : Proper ((≡) ==> (≡) ==> (≡)) (@bi_wand PROP).
Proof. eapply bi_mixin_wand_ne, bi_bi_mixin. Qed.

(* Higher-order logic *)
Lemma pure_intro (φ : Prop) P : φ → P ⊢ ⌜ φ ⌝.
Proof. eapply bi_mixin_pure_intro, bi_bi_mixin. Qed.
Lemma pure_elim' (φ : Prop) P : (φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P.
Proof. eapply bi_mixin_pure_elim', bi_bi_mixin. Qed.

Lemma and_elim_l P Q : P ∧ Q ⊢ P.
Proof. eapply bi_mixin_and_elim_l, bi_bi_mixin. Qed.
Lemma and_elim_r P Q : P ∧ Q ⊢ Q.
Proof. eapply bi_mixin_and_elim_r, bi_bi_mixin. Qed.
Lemma and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R.
Proof. eapply bi_mixin_and_intro, bi_bi_mixin. Qed.

Lemma or_intro_l P Q : P ⊢ P ∨ Q.
Proof. eapply bi_mixin_or_intro_l, bi_bi_mixin. Qed.
Lemma or_intro_r P Q : Q ⊢ P ∨ Q.
Proof. eapply bi_mixin_or_intro_r, bi_bi_mixin. Qed.
Lemma or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R.
Proof. eapply bi_mixin_or_elim, bi_bi_mixin. Qed.

Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R.
Proof. eapply bi_mixin_impl_intro_r, bi_bi_mixin. Qed.
Lemma impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R.
Proof. eapply bi_mixin_impl_elim_l', bi_bi_mixin. Qed.

Lemma forall_intro {A} P (Ψ : A → PROP) : (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a.
Proof. eapply bi_mixin_forall_intro, bi_bi_mixin. Qed.
Lemma forall_elim {A} {Ψ : A → PROP} a : (∀ a, Ψ a) ⊢ Ψ a.
Proof. eapply (bi_mixin_forall_elim bi_entails), bi_bi_mixin. Qed.

Lemma exist_intro {A} {Ψ : A → PROP} a : Ψ a ⊢ ∃ a, Ψ a.
Proof. eapply bi_mixin_exist_intro, bi_bi_mixin. Qed.
Lemma exist_elim {A} (Φ : A → PROP) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q.
Proof. eapply bi_mixin_exist_elim, bi_bi_mixin. Qed.

(* BI connectives *)
Lemma sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'.
Proof. eapply bi_mixin_sep_mono, bi_bi_mixin. Qed.
Lemma emp_sep_1 P : P ⊢ emp ∗ P.
Proof. eapply bi_mixin_emp_sep_1, bi_bi_mixin. Qed.
Lemma emp_sep_2 P : emp ∗ P ⊢ P.
Proof. eapply bi_mixin_emp_sep_2, bi_bi_mixin. Qed.
Lemma sep_comm' P Q : P ∗ Q ⊢ Q ∗ P.
Proof. eapply (bi_mixin_sep_comm' bi_entails), bi_bi_mixin. Qed.
Lemma sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R).
Proof. eapply bi_mixin_sep_assoc', bi_bi_mixin. Qed.
Lemma wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R.
Proof. eapply bi_mixin_wand_intro_r, bi_bi_mixin. Qed.
Lemma wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R.
Proof. eapply bi_mixin_wand_elim_l', bi_bi_mixin. Qed.

End bi_laws.
End bi.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m481_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

(*i $Id: DoubleMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleMul.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w -> zn2z w.
 Variable w_0W : w -> zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable w_succ : w -> w.
 Variable w_add_c : w -> w -> carry w.
 Variable w_add : w -> w -> w.
 Variable w_sub: w -> w -> w.
 Variable w_mul_c : w -> w -> zn2z w.
 Variable w_mul : w -> w -> w.
 Variable w_square_c : w -> zn2z w.
 Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w).
 Variable ww_add   : zn2z w -> zn2z w -> zn2z w.
 Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w.
 Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w).
 Variable ww_sub   : zn2z w -> zn2z w -> zn2z w.

 (* ** Multiplication ** *)

 (*   (xh*B+xl) (yh*B + yl)
   xh*yh         = hh  = |hhh|hhl|B2
   xh*yl +xl*yh  = cc  =     |cch|ccl|B
   xl*yl         = ll  =         |llh|lll
  *)

 Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y :=
  match x, y with
  | W0, _ => W0
  | _, W0 => W0
  | WW xh xl, WW yh yl =>
    let hh := w_mul_c xh yh in
    let ll := w_mul_c xl yl in
    let (wc,cc) := cross xh xl yh yl hh ll in
    match cc with
    | W0 => WW (ww_add hh (w_W0 wc)) ll
    | WW cch ccl =>
      match ww_add_c (w_W0 ccl) ll with
      | C0 l => WW (ww_add hh (w_WW wc cch)) l
      | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
      end
    end
  end.

 Definition ww_mul_c :=
  double_mul_c
    (fun xh xl yh yl hh ll=>
      match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with
      | C0 cc => (w_0, cc)
      | C1 cc => (w_1, cc)
      end).

 Definition w_2 := w_add w_1 w_1.

 Definition kara_prod xh xl yh yl hh ll :=
    match ww_add_c hh ll with
      C0 m =>
         match w_compare xl xh with
           Eq => (w_0, m)
         | Lt =>
           match w_compare yl yh with
             Eq => (w_0, m)
           | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl)))
           | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with
                      C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1)
                   end
           end
         | Gt =>
           match w_compare yl yh with
             Eq => (w_0, m)
           | Lt => match ww_add_c m (w_mul_c (w_sub xl xh)  (w_sub yh yl)) with
                      C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1)
                   end
           | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh)  (w_sub yl yh)))
           end
         end
    | C1 m =>
         match w_compare xl xh with
           Eq => (w_1, m)
         | Lt =>
           match w_compare yl yh with
             Eq => (w_1, m)
           | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with
                    C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1)
                   end
           | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with
                      C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1)
                   end
           end
         | Gt =>
           match w_compare yl yh with
             Eq => (w_1, m)
           | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with
                      C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1)
                   end
           | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with
                     C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1)
                   end
           end
         end
    end.

 Definition ww_karatsuba_c :=  double_mul_c kara_prod.

 Definition ww_mul x y :=
  match x, y with
  | W0, _ => W0
  | _, W0 => W0
  | WW xh xl, WW yh yl =>
    let ccl := w_add (w_mul xh yl) (w_mul xl yh) in
    ww_add (w_W0 ccl) (w_mul_c xl yl)
  end.

 Definition ww_square_c x  :=
  match x with
  | W0 => W0
  | WW xh xl =>
    let hh := w_square_c xh in
    let ll := w_square_c xl in
    let xhxl := w_mul_c xh xl in
    let (wc,cc) :=
      match ww_add_c xhxl xhxl with
      | C0 cc => (w_0, cc)
      | C1 cc => (w_1, cc)
      end in
    match cc with
    | W0 => WW (ww_add hh (w_W0 wc)) ll
    | WW cch ccl =>
      match ww_add_c (w_W0 ccl) ll with
      | C0 l => WW (ww_add hh (w_WW wc cch)) l
      | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
      end
    end
  end.

 Section DoubleMulAddn1.
  Variable w_mul_add : w -> w -> w -> w * w.

  Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n :=
   match n return word w n -> w -> w -> w * word w n with
   | O => w_mul_add
   | S n1 =>
     let mul_add := double_mul_add_n1 n1 in
     fun x y r =>
     match x with
     | W0 => (w_0,extend w_0W n1 r)
     | WW xh xl =>
       let (rl,l) := mul_add xl y r in
       let (rh,h) := mul_add xh y rl in
       (rh, double_WW w_WW n1 h l)
     end
   end.

 End DoubleMulAddn1.

 Section DoubleMulAddmn1.
  Variable wn: Type.
  Variable extend_n : w -> wn.
  Variable wn_0W : wn -> zn2z wn.
  Variable wn_WW : wn -> wn -> zn2z wn.
  Variable w_mul_add_n1 : wn -> w -> w -> w*wn.
  Fixpoint double_mul_add_mn1 (m:nat) :
	word wn m -> w -> w -> w*word wn m :=
   match m return word wn m -> w -> w -> w*word wn m with
   | O => w_mul_add_n1
   | S m1 =>
     let mul_add := double_mul_add_mn1 m1 in
     fun x y r =>
     match x with
     | W0 => (w_0,extend wn_0W m1 (extend_n r))
     | WW xh xl =>
       let (rl,l) := mul_add xl y r in
       let (rh,h) := mul_add xh y rl in
       (rh, double_WW wn_WW m1 h l)
     end
   end.

 End DoubleMulAddmn1.

 Definition w_mul_add x y r :=
  match w_mul_c x y with
  | W0 => (w_0, r)
  | WW h l =>
    match w_add_c l r with
    | C0 lr => (h,lr)
    | C1 lr => (w_succ h, lr)
    end
  end.

 (*Section DoubleProof. *)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).

  Notation "[|| x ||]" :=
    (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x)  (at level 0, x at level 99).

  Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x)
    (at level 0, x at level 99).

  Variable spec_more_than_1_digit: 1 < Zpos w_digits.
  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_1   : [|w_1|] = 1.

  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.

  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_w_compare :
     forall x y,
       match w_compare x y with
       | Eq => [|x|] = [|y|]
       | Lt => [|x|] < [|y|]
       | Gt => [|x|] > [|y|]
       end.
  Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB.
  Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
  Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
  Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.

  Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|].
  Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB.
  Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|].

  Variable spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
  Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB.
  Variable spec_ww_add_carry :
	 forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB.
  Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
  Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].

  Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB.
  Proof. intros x;apply spec_ww_to_Z;auto. Qed.

  Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2.
  Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed.

  Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult.
  Ltac zarith := auto with zarith mult.

  Lemma wBwB_lex: forall a b c d,
      a * wB^2 + [[b]] <= c * wB^2 + [[d]] ->
      a <= c.
  Proof.
   intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith.
  Qed.

  Lemma wBwB_lex_inv: forall a b c d,
      a < c ->
      a * wB^2 + [[b]] < c * wB^2 + [[d]].
  Proof.
   intros a b c d H; apply beta_lex_inv; zarith.
  Qed.

  Lemma sum_mul_carry : forall xh xl yh yl wc cc,
   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] ->
   0 <= [|wc|] <= 1.
  Proof.
   intros.
   apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith.
   apply wB_pos.
  Qed.

  Theorem mult_add_ineq: forall xH yH crossH,
               0 <= [|xH|] * [|yH|] + [|crossH|] < wwB.
  Proof.
   intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith.
  Qed.

  Hint Resolve mult_add_ineq : mult.

  Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll,
   [[hh]] = [|xh|] * [|yh|] ->
   [[ll]] = [|xl|] * [|yl|] ->
   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] ->
    [||match cc with
      | W0 => WW (ww_add hh (w_W0 wc)) ll
      | WW cch ccl =>
          match ww_add_c (w_W0 ccl) ll with
          | C0 l => WW (ww_add hh (w_WW wc cch)) l
          | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
          end
      end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]).
  Proof.
   intros;assert (U1 := wB_pos w_digits).
   replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with
   ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]).
   2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0.
   assert (H2 := sum_mul_carry _ _ _ _ _ _ H1).
   destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z.
   rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small;
    rewrite wwB_wBwB. ring.
   rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith.
   simpl ww_to_Z in H1. assert (U:=spec_to_Z cch).
   assert ([|wc|]*wB + [|cch|] <= 2*wB - 3).
    destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial.
    assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2).
     ring_simplify ((2*wB - 4)*wB + 2).
     assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)).
     assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
     omega.
   generalize H3;clear H3;rewrite <- H1.
   rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc;
     rewrite <- Zmult_plus_distr_l.
    assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB).
     apply Zmult_le_compat;zarith.
    rewrite Zmult_plus_distr_l in H3.
    intros. assert (U2 := spec_to_Z ccl);omega.
   generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll)
   as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l;
   simpl zn2z_to_Z;
   try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW;
   rewrite Zmod_small;rewrite wwB_wBwB;intros.
   rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith.
   rewrite Zplus_assoc;rewrite Zmult_plus_distr_l.
   rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring.
   repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith.
  Qed.

  Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w,
     (forall xh xl yh yl hh ll,
        [[hh]] = [|xh|]*[|yh|] ->
        [[ll]] = [|xl|]*[|yl|] ->
        let (wc,cc) :=  cross xh xl yh yl hh ll in
        [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) ->
     forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]].
  Proof.
   intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial.
   destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial.
   assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl).
   generalize (Hcross _ _ _ _ _ _ H1 H2).
   destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc).
   intros;apply spec_mul_aux;trivial.
   rewrite <- wwB_wBwB;trivial.
  Qed.

  Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]].
  Proof.
   intros x y;unfold ww_mul_c;apply spec_double_mul_c.
   intros xh xl yh yl hh ll H1 H2.
   generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh));
   destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c];
   unfold interp_carry;repeat rewrite spec_w_mul_c;intros H;
   (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring.
  Qed.

  Lemma spec_w_2: [|w_2|] = 2.
  unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl.
  apply Zmod_small; split; auto with zarith.
  rewrite <- (Zpower_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith.
  Qed.

  Lemma kara_prod_aux : forall xh xl yh yl,
   xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh.
  Proof. intros;ring. Qed.

  Lemma spec_kara_prod : forall xh xl yh yl hh ll,
   [[hh]] = [|xh|]*[|yh|] ->
   [[ll]] = [|xl|]*[|yl|] ->
   let (wc,cc) := kara_prod xh xl yh yl hh ll in
   [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|].
  Proof.
   intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux;
     rewrite <- H; rewrite <- H0; unfold kara_prod.
   assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl));
     assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)).
   generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll);
     intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)).
   generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh;
    try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail).
   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh.
   rewrite Hylh; rewrite spec_w_0; try (ring; fail).
   rewrite spec_w_0; try (ring; fail).
   repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   split; auto with zarith.
   simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
   apply Zmult_le_0_compat; auto with zarith.
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2;
     repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh.
   rewrite Hylh; rewrite spec_w_0; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2;
     repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; try (ring; fail).
   repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   split.
   match goal with |- context[(?x - ?y) * (?z - ?t)] =>
     replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
   end.
   simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
   apply Zmult_le_0_compat; auto with zarith.
   (** there is a carry in hh + ll **)
   rewrite Zmult_1_l.
   generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh;
    try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail).
   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh;
     try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
   match goal with |- context[ww_sub_c ?x ?y] =>
     generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
   generalize Hz2; clear Hz2; unfold interp_carry.
   repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_2; unfold interp_carry in Hz2.
   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
   ring.
   rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh;
     try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_2; unfold interp_carry in Hz2.
   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
   ring.
   rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   match goal with |- context[ww_sub_c ?x ?y] =>
     generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
   match goal with |- context[(?x - ?y) * (?z - ?t)] =>
     replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
   end.
   generalize Hz2; clear Hz2; unfold interp_carry.
   repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
  Qed.

  Lemma sub_carry : forall xh xl yh yl z,
    0 <= z ->
    [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z ->
    z < wwB.
  Proof.
   intros xh xl yh yl z Hle Heq.
   destruct (Z_le_gt_dec wwB z);auto with zarith.
   generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)).
   generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
   rewrite <- wwB_wBwB;intros H1 H2.
   assert (H3 := wB_pos w_digits).
   assert (2*wB <= wwB).
    rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith.
   omega.
  Qed.

  Ltac Spec_ww_to_Z x :=
   let H:= fresh "H" in
   assert (H:= spec_ww_to_Z x).

  Ltac Zmult_lt_b x y :=
   let H := fresh "H" in
   assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).

  Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]].
  Proof.
   intros x y; unfold ww_karatsuba_c;apply spec_double_mul_c.
   intros; apply spec_kara_prod; auto.
  Qed.

  Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB.
  Proof.
   assert (U:= lt_0_wB w_digits).
   assert (U1:= lt_0_wwB w_digits).
   intros x y; case x; auto; intros xh xl.
   case y; auto.
   simpl; rewrite Zmult_0_r; rewrite Zmod_small; auto with zarith.
   intros yh yl;simpl.
   repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c
    || rewrite spec_w_add || rewrite spec_w_mul).
   rewrite <- Zplus_mod; auto with zarith.
   repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r).
   rewrite <- Zmult_mod_distr_r; auto with zarith.
   rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith.
   rewrite Zplus_mod; auto with zarith.
   rewrite Zmod_mod; auto with zarith.
   rewrite <- Zplus_mod; auto with zarith.
   match goal with |- ?X mod _ = _ =>
     rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|])
   end; auto with zarith.
   f_equal; auto; rewrite wwB_wBwB; ring.
  Qed.

  Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]].
  Proof.
   destruct x as [ |xh xl];simpl;trivial.
   case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with
          | C0 cc => (w_0, cc)
          | C1 cc => (w_1, cc)
          end;intros wc cc Heq.
   apply (spec_mul_aux xh xl xh xl wc cc);trivial.
   generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq.
   rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));
   unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq;
   rewrite (Zmult_comm [|xl|]);subst.
   rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial.
   rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial.
  Qed.

  Section DoubleMulAddn1Proof.

   Variable w_mul_add : w -> w -> w -> w * w.
   Variable spec_w_mul_add : forall x y r,
    let (h,l):= w_mul_add x y r in
    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].

   Lemma spec_double_mul_add_n1 : forall n x y r,
     let (h,l) := double_mul_add_n1 w_mul_add n x y r in
     [|h|]*double_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|].
   Proof.
    induction n;intros x y r;trivial.
    exact (spec_w_mul_add x y r).
    unfold double_mul_add_n1;destruct x as[ |xh xl];
     fold(double_mul_add_n1 w_mul_add).
    rewrite spec_w_0;rewrite spec_extend;simpl;trivial.
    assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l).
   assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h).
    rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial.
    rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H.
    rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    rewrite U;ring.
   Qed.

  End DoubleMulAddn1Proof.

  Lemma spec_w_mul_add : forall x y r,
    let (h,l):= w_mul_add x y r in
    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].
  Proof.
   intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y);
   destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H.
   rewrite spec_w_0;trivial.
   assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold
   interp_carry in U;try rewrite Zmult_1_l in H;simpl.
   rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small.
   rewrite <- Zplus_assoc;rewrite <- U;ring.
   simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).
   rewrite <- H in H1.
   assert (H2:=spec_to_Z h);split;zarith.
   case H1;clear H1;intro H1;clear H1.
   replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring.
   intros H0;assert (U1:= wB_pos w_digits).
   assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith.
  Qed.

(* End DoubleProof. *)

End DoubleMul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e444m17_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Bool.
Require Import Arith.
Require Import Compare_dec.
Require Import Peano_dec.
Require Import General.
Require Import MyList.
Require Import MyRelations.

Require Export Main.
Require Export SortV6.

Section CoqV6.

  (* Definition des composantes du calcul *)

  Definition trm_v6 := term srt_v6.
  Definition env_v6 := env srt_v6.

  (* Construction du CTS *)

  Definition v6 : CTS_spec srt_v6 :=
    Build_CTS_spec _ axiom_v6 rules_v6 univ_v6 (beta_delta_rule _).

  (* Construction du PTS issu du CTS *)

  Definition v6_pts : PTS_sub_spec srt_v6 := cts_pts_functor _ v6.
  Definition le_type : red_rule srt_v6 :=
    Rule _ (Le_type _ (pts_le_type _ v6_pts)).

  Definition typ_v6 : env_v6 -> trm_v6 -> trm_v6 -> Prop := typ _ v6_pts.
  Definition wft_v6 : env_v6 -> trm_v6 -> Prop := wf_type _ v6_pts.
  Definition wf_v6 : env_v6 -> Prop := wf _ v6_pts.
  Definition v6_sn := sn srt_v6 (ctxt _ (Rule _ (head_reduct _ v6))).

  Hint Unfold le_type typ_v6 wft_v6 wf_v6 v6_sn: pts.

  (* Algorithme de mise en forme normale de tete
     Decidabilite du sous-typage pour les types bien formes *)

  Lemma whnf :
   forall (e : env_v6) (t : trm_v6),
   v6_sn e t ->
   {u : trm_v6 | red _ (beta_delta _) e t u &
   head_normal _ (beta_delta _) e u}.
Proof beta_delta_whnf srt_v6.

  Lemma bd_conv_hnf :
   forall (e : env_v6) (x y : trm_v6),
   v6_sn e x -> v6_sn e y -> decide (conv_hn_inv _ (beta_delta_rule _) e x y).
Proof
  CR_WHNF_convert_hn srt_v6 v6_sort_dec (beta_delta_rule srt_v6)
    (church_rosser_beta_delta srt_v6) whnf.

  Theorem v6_is_subtype_dec : subtype_dec_CTS _ v6.
apply Build_subtype_dec_CTS.
exact (church_rosser_beta_delta srt_v6).

exact (bd_hn_sort srt_v6).

exact (bd_hn_prod srt_v6).

exact whnf.

exact bd_conv_hnf.

exact univ_v6_dec.
Qed.

  (* Subject-Reduction *)

  Lemma sound_v6_bd : rule_sound _ v6_pts (beta_delta _).
unfold beta_delta in |- *.
simpl in |- *.
apply union_sound.
apply beta_sound; auto with arith pts.
simpl in |- *.
apply cumul_inv_prod.
exact v6_is_subtype_dec.

apply delta_sound.
Qed.

  (* L'axiome:  ECC est fortement normalisant *)

  Axiom
    v6_normalise :
      forall (e : env_v6) (t T : trm_v6), typ_v6 e t T -> v6_sn e t.

  Lemma v6_is_norm_sound : norm_sound_CTS _ v6.
Proof.
refine (Build_norm_sound_CTS srt_v6 v6 sound_v6_bd v6_normalise _ _ _).
left.
apply v6_inf_axiom.

exact v6_inf_rule.

intros.
elim v6_inf_axiom with s1; intros.
split with x.
apply (pp_ok p).
Qed.

  (* Construction du type-checker *)

  Theorem v6_algorithms : PTS_TC _ v6_pts.
  Proof full_cts_type_checker srt_v6 v6 v6_is_subtype_dec v6_is_norm_sound.

  (* open the type-checker *)

  Lemma infer_type :
   forall (e : env_v6) (t : trm_v6), wf_v6 e -> infer_ppal_type _ v6_pts e t.
Proof ptc_inf_ppal_type _ _ v6_algorithms.

  Lemma check_wf_type :
   forall (e : env_v6) (t : trm_v6), wf_v6 e -> wft_dec _ v6_pts e t.
Proof ptc_chk_wft _ _ v6_algorithms.

  Lemma check_type :
   forall (e : env_v6) (t T : trm_v6), wf_v6 e -> check_dec _ v6_pts e t T.
Proof ptc_chk_typ _ _ v6_algorithms.

  Lemma add_type :
   forall (e : env_v6) (t : trm_v6), wf_v6 e -> decl_dec _ v6_pts e (Ax _ t).
Proof ptc_add_typ _ _ v6_algorithms.

  Lemma add_def :
   forall (e : env_v6) (t T : trm_v6),
   wf_v6 e -> decl_dec _ v6_pts e (Def _ t T).
Proof ptc_add_def _ _ v6_algorithms.

End CoqV6.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e512m569_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e338m15_14limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus lv0 lv1)) (plus (Succ lv1) lv0)).
Admitted.
QuickChick conj12synthconj5.


From mathcomp
Require Import all_ssreflect.

From chip
Require Import extra connect acyclic closure check change hierarchical_sub.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section ChangedHierarchicalSub.

Variables (A_top : eqType) (A_bot : eqType).

Variables (U' : finType) (V' : finType).

Variables (f'_top : U' -> A_top) (f'_bot : V' -> A_bot).

Variables (P_top : pred U') (P_bot : pred V').

Local Notation U := (sig_finType P_top).

Local Notation V := (sig_finType P_bot).

Variable (g'_top : rel U') (g'_bot : rel V').

Local Notation g'_top_rev := [rel x y | g'_top y x].

Local Notation g'_bot_rev := [rel x y | g'_bot y x].

Variables (f_top : U -> A_top) (f_bot : V -> A_bot).

Variables (g_top : rel U) (g_bot : rel V).

Local Notation g_top_rev := [rel x y | g_top y x].

Local Notation g_bot_rev := [rel x y | g_bot y x].

Variables (checkable' : pred V') (checkable : pred V).

Variable R : eqType.

Variables (check : V -> R) (check' : V' -> R).

Variables (p : U -> {set V}) (p' : U' -> {set V'}).

Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'.

Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'.

Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V].

Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V'].

Hypothesis g_bot_top : forall (v v' : V) (u u' : U),
 u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'.

Hypothesis f_top_bot : forall (u : U),
 f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v).

Local Notation insub_g_top x y := (insub_g g_top x y).

Local Notation g_top_U' := [rel x y : U' | insub_g_top x y].

Local Notation g_top_U'_rev := [rel x y | g_top_U' y x].

Local Notation insub_g_bot x y := (insub_g g_bot x y).

Local Notation g_bot_V' := [rel x y : V' | insub_g_bot x y].

Local Notation g_bot_V'_rev := [rel x y | g_bot_V' y x].

Hypothesis f_top_equal_g_top :
  forall u, f_top u = f'_top (val u) -> forall u', g_top_U' (val u) u' = g'_top (val u) u'.

Hypothesis f_bot_equal_g_bot :
  forall v, f_bot v = f'_bot (val v) -> forall v', g_bot_V' (val v) v' = g'_bot (val v) v'.

Hypothesis checkable_bot :
  forall v, f_bot v = f'_bot (val v) -> checkable v = checkable' (val v).

Hypothesis check_bot :
  forall v, checkable v -> checkable' (val v) ->
  (forall v', connect g_bot_V' (val v) v' = connect g'_bot (val v) v') ->
  (forall v', connect g_bot_V' (val v) (val v') -> f_bot v' = f'_bot (val v')) ->
  check v = check' (val v).

Variable V_result_cert : seq (V * R).

Hypothesis V_result_certP :
  forall v r, reflect (checkable v /\ check v = r) ((v,r) \in V_result_cert).

Hypothesis V_result_cert_uniq : uniq [seq vr.1 | vr <- V_result_cert].

Local Notation V_sub := (sig_finType (P_V_sub f'_top g_top f_top p)).

Local Notation g_bot_sub := [rel x y : V_sub | g_bot (val x) (val y)].

Definition V'_result_filter_cert_sub :=
  [seq (val vr.1, vr.2) | vr <- V_result_cert & val vr.1 \notin impactedVV' g_bot (modifiedV f'_bot f_bot)].

Definition check_all_cert_sub :=
  check_impactedV'_sub_cert f'_top f'_bot g_top g_bot f_top f_bot checkable' check' p ++ V'_result_filter_cert_sub.

Definition check_all_cert_V'_sub :=
 [seq vr.1 | vr <- check_all_cert_sub].

Lemma check_all_cert_complete_sub :
  forall (v : V'), checkable' v -> v \in check_all_cert_V'_sub.
Proof.
move => v Hc.
rewrite /check_all_cert_V'_sub /check_all_cert_sub.
rewrite /check_impactedV'_sub_cert.
rewrite /checkable_impacted_fresh_sub.
rewrite /checkable_impactedV'_sub.
rewrite impactedV'_sub_eq.
apply: check_all_cert_complete; eauto.
- exact: p_neq.
- exact: p_partition.
- exact: g_bot_top.
- exact: f_top_bot.
Qed.

Lemma check_all_cert_sound_sub :
  forall (v : V') (r : R), (v,r) \in check_all_cert_sub ->
  checkable' v /\ check' v = r.
Proof.
move => v r.
rewrite /check_all_cert_sub.
rewrite /check_impactedV'_sub_cert.
rewrite /checkable_impacted_fresh_sub.
rewrite /checkable_impactedV'_sub.
rewrite impactedV'_sub_eq.
apply: check_all_cert_sound; eauto.
- exact: p_neq.
- exact: p_partition.
- exact: g_bot_top.
- exact: f_top_bot.
Qed.

Lemma check_all_cert_V'_sub_uniq : uniq check_all_cert_V'_sub.
Proof.
rewrite /check_all_cert_V'_sub.
rewrite /check_all_cert_sub.
rewrite /check_impactedV'_sub_cert.
rewrite /checkable_impacted_fresh_sub.
rewrite /checkable_impactedV'_sub.
rewrite impactedV'_sub_eq.
apply: check_all_cert_V'_uniq; eauto.
- exact: p_neq.
- exact: p_partition.
- exact: g_bot_top.
- exact: f_top_bot.
Qed.

End ChangedHierarchicalSub.


Require Import
        Coq.Lists.List
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.QueryStructure.Specification.Representation.QueryStructure.

Definition DuplicateFree {heading} (tup1 tup2 : @RawTuple heading) := tup1 <> tup2.

Fixpoint BuildFinUpTo (n : nat) {struct n} : list (Fin.t n) :=
  match n return list (Fin.t n) with
  | 0  => nil
  | S n' => cons (@Fin.F1 _) (map (@Fin.FS _) (BuildFinUpTo n'))
  end.

Definition allAttributes heading
  : list (Attributes heading) :=
  BuildFinUpTo (NumAttr heading).

Fixpoint tupleAgree_computational'
         {h}
         (tup1 tup2 : @RawTuple h)
         (attrlist : list (Attributes h))
  {struct attrlist} :=
  match attrlist with
  | nil => True
  | cons attr nil => GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr
  | attr :: more => GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr /\ tupleAgree_computational' tup1 tup2 more
  end.


(* Instruction Machine *)
Require Import assembly util relations.
Require Import Unicode.Utf8.
Require Import List.
Import ListNotations.
Require Import util.

Definition Heap := Map Ptr Word.
Definition Stack := list Word.

(*
Definition RegisterFile := Reg → Ptr.
Definition upd (r: Reg) (p: Ptr) (rf: RegisterFile) : RegisterFile := match r with
  | IP => λ r, match r with | IP => p | _ => rf r end
  | EP => λ r, match r with | EP => p | _ => rf r end
  | R1 => λ r, match r with | R1 => p | _ => rf r end
  | R2 => λ r, match r with | R2 => p | _ => rf r end
  | R3 => λ r, match r with | R3 => p | _ => rf r end
  end.
*)

Inductive RegisterFile := mkrf {
  ip : Ptr;
  ep : Ptr;
  r1 : Ptr;
  r2 : Ptr
}.

Definition upd (r: Reg) (p: Ptr) (rf: RegisterFile) : RegisterFile := match r,rf with
  | IP, mkrf ip ep r1 r2 => mkrf p ep r1 r2
  | EP, mkrf ip ep r1 r2 => mkrf ip p r1 r2
  | R1, mkrf ip ep r1 r2 => mkrf ip ep p r2
  | R2, mkrf ip ep r1 r2 => mkrf ip ep r1 p
  end.

Definition rff (rf : RegisterFile) (r: Reg) : Ptr := match r with
  | IP => ip rf
  | EP => ep rf
  | R1 => r1 rf
  | R2 => r2 rf
  end.

Inductive State := st {
  st_rf : RegisterFile;
  st_p : Program;
  st_s : Stack;
  st_h  : Heap
}.

Definition I (p : Program) : State := st (mkrf 0 0 0 0) p nil nil.

Open Scope nat_scope.
Inductive read : RO → State → Ptr → Type :=
  | read_reg : ∀ r s, read (RW (WR r)) s (rff (st_rf s) r)
  | read_mem : ∀ r o rf p s h v,
    lookup (o+rff rf r) h = Some v →
    read (RW (WM r o)) (st rf p s h) v
  | read_const : ∀ c s, read (RC c) s c.

Inductive write : WO → Word → State → State → Type :=
  | write_reg : ∀ r rf p s h w,
    write (WR r) w (st rf p s h) (st (upd r w rf) p s h)
  | write_mem : ∀ r o rf p s h w,
    write (WM r o) w (st rf p s h)
                     (st rf p s (replace beq_nat (o+rff rf r) w h)).

Fixpoint zeroes (n : nat) (p : Ptr) := match n with
  | 0 => []
  | S n => (p, 0)::zeroes n (S p)
  end.

Inductive step_bb : BasicBlock → State → State → Type :=
  | step_push : ∀ rf p s h ro is v sn,
  read ro (st rf p s h) v →
  step_bb is (st rf p (v::s) h) sn →
  step_bb (instr (push ro) is) (st rf p s h) sn
  | step_pop : ∀ rf p s h wo is w s' sn,
  write wo w (st rf p s h) s' →
  step_bb is s' sn →
  step_bb (instr (pop wo) is) (st rf p (w::s) h) sn
  | step_new : ∀ rf p s h wo is w s' n sn,
  (∀ i, i < n → not (In (i+w) (domain h))) →
  w > 0 →
  write wo w (st rf p s (zeroes n w ++ h)) s' →
  step_bb is s' sn →
  step_bb (instr (new n wo) is) (st rf p s h) sn
  | step_mov : ∀ s is ro wo s' v sn,
  read ro s v → write wo v s s' →
  step_bb is s' sn →
  step_bb (instr (mov ro wo) is) s sn
  | step_jump0 : ∀ ro k j s s',
  read ro s 0 →
  write (WR IP) k s s' →
  step_bb (jump (Some (ro, k)) j) s s'
  | step_jumpS : ∀ ro k j s s' l k',
  l > 0 →
  read ro s l →
  read j s k →
  write (WR IP) k s s' →
  step_bb (jump (Some (ro, k')) j) s s'
  | step_jump : ∀ ro s s' l,
  read ro s l →
  write (WR IP) l s s' →
  step_bb (jump None ro) s s'
.

Inductive step : transition State :=
  | enter : ∀ rf p s h k bb sn,
    read IP (st rf p s h) k →
    nth_error p k = Some bb →
    step_bb bb (st rf p s h) sn →
    step (st rf p s h) sn.


Require Import Raft.
Require Import RaftRefinementInterface.
Require Import CommonDefinitions.

Section VotesWithLogSorted.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votesWithLog_sorted (net : network) : Prop :=
    forall h t h' log,
      In (t, h', log) (votesWithLog (fst (nwState net h))) ->
      sorted log.

  Class votesWithLog_sorted_interface : Prop :=
    {
      votesWithLog_sorted_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votesWithLog_sorted net
    }.
End VotesWithLogSorted.


(* Some tests of the SearchRewrite command *)

SearchRewrite (_+0). 			(* left *)
SearchRewrite (0+_). 			(* right *)

Definition newdef := fun x:nat => x.

Goal forall n:nat, n = newdef n -> False.
  intros n h.
  SearchRewrite (newdef _).
  SearchRewrite n.                (* use hypothesis for patterns *)
  SearchRewrite (newdef n).       (* use hypothesis for patterns *)
Abort.


Require Import List.
Require Import String.
Require Import ZArith.

Open Scope list_scope.
Open Scope string_scope.
Open Scope Z_scope.

Require Import Frap.

Require Import Imp.StructTactics.
Require Import Imp.ImpSyntax.
Require Import Imp.ImpCommon.
Require Import Imp.ImpEval.
Require Import Imp.ImpSemanticsFacts.
Require Import Imp.ImpInterp.

(*
 * In this file, you will prove a correspondence between your interpreter and
 * your semantics.
 *
 * Some of the lemmas from ImpCommon.v and ImpSemanticsFacts.v will be useful
 * in these proofs, so you should make sure you are familiar with the lemmas
 * in those files.
 *
 * We have also included some useful tactics to help you with your proofs.
 * For example, while we could prove that unary operators behave as
 * expected this way (this is purposely extremely manual so you can step through it):
 *)
Lemma interp_op1_eval_op1' :
  forall op v v',
    interp_op1 op v = Some v' ->
    eval_unop op v v'.
Proof.
  unfold interp_op1. intros.
  destruct op.
  - destruct v.
    + discriminate.
    + inversion H. constructor.
    + discriminate.
    + discriminate.
  - destruct v.
    + inversion H. constructor.
    + discriminate.
    + discriminate.
    + discriminate.
Qed.
(*
 * We can use the break_match tactic to automatically destruct on both
 * op and v, and then use Coq's tacticals (repeat, try, and the semicolon)
 * to make the proof very concise:
 *)
Lemma interp_op1_eval_op1 :
  forall op v v',
    interp_op1 op v = Some v' ->
    eval_unop op v v'.
Proof.
  unfold interp_op1; intros.
  repeat break_match; subst; try discriminate; inversion H; constructor.
Qed.
(*
 * You will almost certainly want to use the break_match tactic to simplify
 * your proofs in this section.
 *)

Lemma eval_op1_interp_op1 :
  forall op v v',
    eval_unop op v v' ->
    interp_op1 op v = Some v'.
Proof.
  inversion 1; auto.
Qed.

(*
 * Problem 3 [15 points, ~10 tactics]: Complete this proof.
 *
 * Hint: Read about the break_match tactic and Coq's tacticals above
 * before writing this proof.
 *)
Lemma interp_op2_eval_op2 :
  forall op v1 v2 v',
    interp_op2 op v1 v2 = Some v' ->
    eval_binop op v1 v2 v'.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)

(*
 * Problem 1 continued (correctness test) [necessary to get points for Problem 1]:
 * Uncomment this proof. This proof should go through once you have completed
 * the problems in ImpInterp.v. If it does not, fix your interp_op2 code.
 *)
Lemma eval_op2_interp_op2 :
  forall op v1 v2 v',
    eval_binop op v1 v2 v' ->
    interp_op2 op v1 v2 = Some v'.
Proof.
  (* inversion 1; auto.
  - simpl. break_match; [congruence | auto].
  - simpl. break_match; [congruence | auto].*) (* UNCOMMENT *)
Admitted. (* CHANGE TO QED *)

Lemma interp_e_eval_e :
  forall s h e v,
    interp_e s h e = Some v ->
    eval_e s h e v.
Proof.
  induction e; simpl; intros.
  - inv H; ee.
  - ee.
  - repeat break_match; try discriminate.
    ee. apply interp_op1_eval_op1; auto.
  - repeat break_match; try discriminate.
    ee. apply interp_op2_eval_op2; auto.
  - repeat break_match; try discriminate.
    + find_inversion. eapply eval_len_s; eauto.
    + find_inversion. eapply eval_len_a; eauto.
  - repeat break_match; try discriminate.
    + find_inversion. eapply eval_idx_s; eauto.
    + eapply eval_idx_a; eauto.
Qed.

Lemma eval_e_interp_e :
  forall s h e v,
    eval_e s h e v ->
    interp_e s h e = Some v.
Proof.
  induction 1; simpl; auto.
  - repeat break_match; try discriminate.
    find_inversion. apply eval_op1_interp_op1; auto.
  - repeat break_match; try discriminate.
    repeat find_inversion. apply eval_op2_interp_op2; auto.
  - break_match; try discriminate. find_inversion.
    break_match; try discriminate. find_inversion.
    reflexivity.
  - break_match; try discriminate.
    find_inversion. reflexivity.
  - break_match; try discriminate.
    find_inversion. repeat find_rewrite.
    do 2 (break_match; try omega). auto.
  - break_match; try discriminate. find_inversion.
    break_match; try discriminate. find_inversion.
    break_match; try omega.
    break_match; try discriminate.
    find_inversion; auto.
Qed.

Lemma interps_e_evals_e :
  forall s h es vs,
    interps_e s h es = Some vs ->
    evals_e s h es vs.
Proof.
  induction es; simpl; intros.
  - find_inversion. ee.
  - repeat break_match; try discriminate.
    find_inversion. ee.
    apply interp_e_eval_e; auto.
Qed.

Lemma evals_e_interps_e :
  forall s h es vs,
    evals_e s h es vs ->
    interps_e s h es = Some vs.
Proof.
  induction 1; simpl; intros; auto.
  find_apply_lem_hyp eval_e_interp_e.
  repeat find_rewrite. auto.
Qed.

(*
 * Problem 4 [40 points, <100 tactics]: Prove interp_s_eval_s.
 *
 * Hint: You will likely want the break_match tactic again.
 * You should also familiarize yourself with the lemmas in ImpCommon.v and
 * ImpSemanticsFacts.v before writing this proof, and consider using them
 * if you get stuck.
 *)
Lemma interp_s_eval_s :
  forall fuel env s h p s' h',
    interp_s fuel env s h p = Some (s', h') ->
    eval_s env s h p s' h'.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)

Lemma interp_p_eval_p :
  forall n funcs main ret h' v',
    interp_p n (Prog funcs main ret) = Some (h', v') ->
    eval_p (Prog funcs main ret) h' v'.
Proof.
  unfold interp_p; intros.
  repeat break_match; try discriminate.
  repeat find_inversion.
  find_apply_lem_hyp interp_s_eval_s.
  find_apply_lem_hyp interp_e_eval_e.
  ee.
Qed.


Require Import Crypto.Specific.NISTP256.FancyMachine256.Core.
Require Import LegacyArithmetic.BarretReduction.
Require Import Crypto.Arithmetic.BarrettReduction.HAC.

(** Useful for arithmetic in the field of integers modulo the order of the curve25519 base point *)
Section expression.
  Let b : Z := 2.
  Let k : Z := 253.
  Let offset : Z := 3.
  Context (ops : fancy_machine.instructions (2 * 128)) (props : fancy_machine.arithmetic ops).
  Context (m μ : Z)
          (m_pos : 0 < m).
  Let base_pos : 0 < b. reflexivity. Qed.
  Context (k_good : m < b^k)
          (μ_good : μ = b^(2*k) / m) (* [/] is [Z.div], which is truncated *).
  Let offset_nonneg : 0 <= offset. unfold offset; omega. Qed.
  Let k_big_enough : offset <= k. unfold offset, k; omega. Qed.
  Context (m_small : 3 * m <= b^(k+offset))
          (m_large : b^(k-offset) <= m + 1).
  Context (H : 0 <= m < 2^256).
  Let H' : 0 <= 250 <= 256. omega. Qed.
  Let H'' : 0 < 250. omega. Qed.
  Local Notation SmallT := (@ZBounded.SmallT (2 ^ 256) (2 ^ 250) m
                                  (@ZLikeOps_of_ArchitectureBoundedOps 128 ops m _)).
  Definition ldi' : load_immediate SmallT := _.
  Let isldi : is_load_immediate ldi' := _.
  Context (μ_range : 0 <= b ^ (2 * k) / m < b ^ (k + offset)).
  Definition μ' : SmallT := ldi' μ.
  Let μ'_eq : ZBounded.decode_small μ' = μ.
  Proof.
    unfold ZBounded.decode_small, ZLikeOps_of_ArchitectureBoundedOps, μ'.
    apply (decode_load_immediate _ _).
    rewrite μ_good; apply μ_range.
  Qed.

  Let props'
      ldi_modulus ldi_0 Hldi_modulus Hldi_0
    := ZLikeProperties_of_ArchitectureBoundedOps_Factored ops m ldi_modulus ldi_0 Hldi_modulus Hldi_0 H 250 H' H''.

  Definition pre_f' ldi_modulus ldi_0 ldi_μ Hldi_modulus Hldi_0 (Hldi_μ : ldi_μ = ldi' μ)
    := (fun v => (@barrett_reduce m b k μ offset m_pos base_pos μ_good offset_nonneg k_big_enough m_small m_large _ (props' ldi_modulus ldi_0 Hldi_modulus Hldi_0) ldi_μ I (eq_trans (f_equal _ Hldi_μ) μ'_eq)  (fst v, snd v))).

  Definition pre_f := pre_f' _ _ _ eq_refl eq_refl eq_refl.

  Local Arguments μ' / .
  Local Arguments ldi' / .
  Local Arguments Core.mul_double / _ _ _ _ _ _ _ _ _ _.
  Local Opaque Let_In Let_In_pf.

  Definition expression'
    := Eval simpl in
        (fun v => pflet ldi_modulus, Hldi_modulus := fancy_machine.ldi m in
                  pflet ldi_μ, Hldi_μ := fancy_machine.ldi μ in
                  pflet ldi_0, Hldi_0 := fancy_machine.ldi 0 in
                  proj1_sig (pre_f' ldi_modulus ldi_0 ldi_μ Hldi_modulus Hldi_0 Hldi_μ v)).
  Local Transparent Let_In Let_In_pf.
  Definition expression
    := Eval cbv beta iota delta [expression' fst snd Let_In Let_In_pf] in expression'.

  Definition expression_eq v (H : 0 <= _ < _) : fancy_machine.decode (expression v) = _
    := proj1 (proj2_sig (pre_f v) H).
End expression.

Section reflected.
  Context (ops : fancy_machine.instructions (2 * 128)).
  Local Notation tZ := (Tbase TZ).
  Local Notation tW := (Tbase TW).
  Definition rexpression : Syntax.Expr base_type op (Arrow (tZ * tZ * tW * tW) tW).
  Proof.
    let v := (eval cbv beta delta [expression] in (fun mμxy => let '(mv, μv, xv, yv) := mμxy in expression ops mv μv (xv, yv))) in
    let v := Reify v in
    exact v.
  Defined.

  Definition rexpression_simple := Eval vm_compute in rexpression.

  (*Compute DefaultRegisters rexpression_simple.*)

  Definition registers
    := [RegMod; RegMuLow; x; xHigh; RegMod; RegMuLow; RegZero; tmp; q; qHigh; scratch+3;
       SpecialCarryBit; q; SpecialCarryBit; qHigh; scratch+3; SpecialCarryBit; q; SpecialCarryBit; qHigh; tmp;
       scratch+3; SpecialCarryBit; tmp; scratch+3; SpecialCarryBit; tmp; SpecialCarryBit; tmp; q; out].

  Definition compiled_syntax
    := Eval lazy in AssembleSyntax rexpression_simple registers.

  Context (m μ : Z)
          (props : fancy_machine.arithmetic ops).

  Let result (v : Tuple.tuple fancy_machine.W 2) := Syntax.Interp (@interp_op _) rexpression_simple (m, μ, fst v, snd v).
  Let assembled_result (v : Tuple.tuple fancy_machine.W 2) : fancy_machine.W := Core.Interp compiled_syntax (m, μ, fst v, snd v).

  Theorem sanity : result = expression ops m μ.
  Proof using Type.
    reflexivity.
  Qed.

  Theorem assembled_sanity : assembled_result = expression ops m μ.
  Proof using Type.
    reflexivity.
  Qed.

  Section correctness.
    Let b : Z := 2.
    Let k : Z := 253.
    Let offset : Z := 3.
    Context (H0 : 0 < m)
            (H1 : μ = b^(2 * k) / m)
            (H2 : 3 * m <= b^(k + offset))
            (H3 : b^(k - offset) <= m + 1)
            (H4 : 0 <= m < 2^(k + offset))
            (H5 : 0 <= b^(2 * k) / m < b^(k + offset))
            (v : Tuple.tuple fancy_machine.W 2)
            (H6 : 0 <= decode v < b^(2 * k)).
    Theorem correctness : fancy_machine.decode (result v) = decode v mod m.
    Proof using H0 H1 H2 H3 H4 H5 H6 props.
      rewrite sanity; destruct v.
      apply expression_eq; assumption.
    Qed.
    Theorem assembled_correctness : fancy_machine.decode (assembled_result v) = decode v mod m.
    Proof using H0 H1 H2 H3 H4 H5 H6 props.
      rewrite assembled_sanity; destruct v.
      apply expression_eq; assumption.
    Qed.
  End correctness.
End reflected.

Print compiled_syntax.
(* compiled_syntax =
fun ops : fancy_machine.instructions (2 * 128) =>
λn (RegMod, RegMuLow, x, xHigh),
nlet RegMod := RegMod in
nlet RegMuLow := RegMuLow in
nlet RegZero := ldi 0 in
c.Rshi(tmp, xHigh, x, 250),
c.Mul128(q, c.LowerHalf(tmp), c.LowerHalf(RegMuLow)),
c.Mul128(qHigh, c.UpperHalf(tmp), c.UpperHalf(RegMuLow)),
c.Mul128(scratch+3, c.UpperHalf(tmp), c.LowerHalf(RegMuLow)),
c.Add(q, q, c.LeftShifted{scratch+3, 128}),
c.Addc(qHigh, qHigh, c.RightShifted{scratch+3, 128}),
c.Mul128(scratch+3, c.UpperHalf(RegMuLow), c.LowerHalf(tmp)),
c.Add(q, q, c.LeftShifted{scratch+3, 128}),
c.Addc(qHigh, qHigh, c.RightShifted{scratch+3, 128}),
c.Mul128(tmp, c.LowerHalf(qHigh), c.LowerHalf(RegMod)),
c.Mul128(scratch+3, c.UpperHalf(qHigh), c.LowerHalf(RegMod)),
c.Add(tmp, tmp, c.LeftShifted{scratch+3, 128}),
c.Mul128(scratch+3, c.UpperHalf(RegMod), c.LowerHalf(qHigh)),
c.Add(tmp, tmp, c.LeftShifted{scratch+3, 128}),
c.Sub(tmp, x, tmp),
c.Addm(q, tmp, RegZero),
c.Addm(out, q, RegZero),
Return out
     : forall ops : fancy_machine.instructions (2 * 128),
       expr base_type op Register (Tbase TZ * Tbase TZ * Tbase TW * Tbase TW -> Tbase TW)
*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Forcing.

Inductive Obj := O.
Definition Hom (p q : Obj) := bool.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Definition eq (A : Type) (x y : A) : Prop := forall (P : A -> Prop), P x -> P y.
Definition refl : forall A (x : A), eq A x x := fun A x P p => p.
Definition eq_rect : forall (A : Type) (x : A) (P : A -> Prop), P x -> forall y : A, eq A x y -> P y :=
  fun A x P p y e => e P p.

Forcing Translate eq using Obj Hom.
Forcing Translate refl using Obj Hom.
Forcing Translate eq_rect using Obj Hom.

Forcing Definition Empty : Type using Obj Hom.
Proof.
intros p q α.
exact False.
Defined.

Forcing Definition Empty_rect : forall A, Empty -> A using Obj Hom.
Proof.
intros p A e.
destruct (e p #).
Defined.

Definition propext := forall (A B : Prop), (A -> B) -> (B -> A) -> eq Prop A B.

Forcing Translate propext using Obj Hom.

Definition A₀ := fun p q (α : p ≤ q) r (β : q ≤ r) => True.
Definition A₁ := fun p q (α : p ≤ q) r (β : q ≤ r) => if β r Datatypes.true then True else False.

Definition lift {p q} (α : Hom p q) : p ≤ q := fun r β => xorb α β.

Forcing Definition neg_propext : propext -> Empty using Obj Hom.
Proof.
intros p hpext.
specialize (hpext p # (A₀ p) (A₁ p) (fun q α H => I) (fun q α H => I)).
compute in hpext.
specialize (hpext (fun q α H r β => H r β r (@lift r r true))).
compute in *.
apply hpext.
intros; constructor.
Qed.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Require Import LIR.maps.

Require LIR.lir.

(* Pallene types *)
Inductive PType : Set :=
| PTStar : PType
| PTNil : PType
| PTInt : PType
| PTArr : PType -> PType
| PTFun : PType -> PType -> PType
.

Lemma dec_TP : forall (t1 t2 : PType), {t1 = t2} + {t1 <> t2}.
Proof. decide equality. Defined.

(* Type environment for Pallene *)
Definition PEnvironment := Map PType.

(*
** Syntax of λ-Pallene
*)
Inductive PE : Set :=
| PENil : PE
| PENum : nat -> PE
| PEPlus : PE -> PE -> PE
| PENew : PType -> PE
| PETAddr : lir.address -> PType -> PE
| PEFAddr : lir.address -> PType -> PType -> PE
| PEGet : PE -> PE -> PE
| PESet : PE -> PE -> PE -> PE
| PEVar : string -> PE
| PEApp :  PE -> PE -> PE
| PEFun : string -> PType -> PE -> PType -> PE
| PELet : string -> PType -> PE -> PE -> PE
| PECast : PE -> PType -> PE
.

(*
** Typing rules for λ-Pallene
*)
Reserved Notation "Γ '|p=' e ':' t"  (at level 40, no associativity,
                                     e at next level).

Inductive PTyping : PEnvironment -> PE -> PType -> Prop :=
| PTyNil : forall Γ, Γ |p= PENil : PTNil
| PTyInt : forall Γ n, Γ |p= PENum n : PTInt
| PTyVal : forall Γ var T,
    In Γ var = Some T ->
    Γ |p= PEVar var : T
| PTyPlus : forall Γ e1 e2,
    Γ |p= e1 : PTInt ->
    Γ |p= e2 : PTInt ->
    Γ |p= PEPlus e1 e2 : PTInt
| PTyNew : forall Γ T, Γ |p= PENew T : PTArr T
| PTyTAddr : forall Γ a T, Γ |p= PETAddr a T : PTArr T
| PTyFAddr : forall Γ a T1 T2, Γ |p= PEFAddr a T1 T2 : PTFun T1 T2
| PTyGet : forall Γ e1 T e2,
    Γ |p= e1 : PTArr T ->
    Γ |p= e2 : PTInt ->
    Γ |p= PEGet e1 e2 : T
| PTySet : forall Γ e1 T e2 e3,
    Γ |p= e1 : PTArr T ->
    Γ |p= e2 : PTInt ->
    Γ |p= e3 : T ->
    Γ |p= PESet e1 e2 e3 : PTNil
| PTyFun : forall Γ var Tvar body Tbody,
    (var |=> Tvar; Γ) |p= body : Tbody ->
    Γ |p= PEFun var Tvar body Tbody : PTFun Tvar Tbody
| PTyLet : forall Γ var Tvar init body Tbody,
    Γ |p= init : Tvar ->
    (var |=> Tvar; Γ) |p= body : Tbody ->
    Γ |p= PELet var Tvar init body : Tbody
| PTyApp : forall Γ e1 e2 T1 T2,
    Γ |p= e1 : PTFun T1 T2 ->
    Γ |p= e2 : T1 ->
    Γ |p= PEApp e1 e2 : T2
| PTyCast : forall Γ e T1 T2,
    Γ |p= e : T1 ->
    Γ |p= PECast e T2 : T2

where "Γ '|p=' e ':' t" := (PTyping Γ e t)
.

(*
** Typing algorithm for λ-Pallene
*)
Fixpoint typeOf Γ e : option PType :=
  match e with
  | PENil => Some PTNil
  | PENum _ => Some PTInt
  | PEPlus e1 e2 =>
    match (typeOf Γ e1), (typeOf Γ e2) with
    | Some PTInt, Some PTInt => Some PTInt
    | _, _ => None
    end
  | PENew T => Some (PTArr T)
  | PETAddr _ T => Some (PTArr T)
  | PEFAddr _ T1 T2 => Some (PTFun T1 T2)
  | PEGet e1 e2 =>
    match (typeOf Γ e1), (typeOf Γ e2) with
    | Some (PTArr T), Some PTInt => Some T
    | _, _ => None
    end
  | PESet e1 e2 e3 =>
    match (typeOf Γ e1), (typeOf Γ e2), (typeOf Γ e3) with
    | Some (PTArr T), Some PTInt, Some T' =>
        if dec_TP T T' then Some PTNil else None
    | _, _, _ => None
    end
  | PEVar var => In Γ var
  | PEApp e1 e2 =>
    match typeOf Γ e1, typeOf Γ e2 with
    | Some (PTFun T1 T2), Some T1' =>
        if dec_TP T1 T1' then Some T2 else None
    | _, _ => None
    end
  | PEFun var Tv e Tb =>
    match typeOf (var |=> Tv; Γ) e with
    | Some Tb' => if dec_TP Tb Tb' then Some (PTFun Tv Tb) else None
    | None => None
    end
  | PELet var Tv init body =>
    match typeOf Γ init, typeOf (var |=> Tv; Γ) body with
    | Some Tv', Some Tb =>
        if dec_TP Tv Tv' then Some Tb else None
    | _, _ => None
    end
  | PECast e T =>
    match typeOf Γ e with
    | Some _ => Some T
    | None => None
    end
  end.

(*
** 'typeOf' is correct (part 1)
*)
Lemma typeOfCorrect' : forall Γ e T, Γ |p= e : T -> typeOf Γ e = Some T.
Proof.
  induction 1; try easy;
  simpl;
  repeat match goal with
  | [H: typeOf _ _ = Some _ |- _] => rewrite H; clear H
  | [ |- context [dec_TP ?V1 ?V2] ] => destruct (dec_TP V1 V2)
  end; easy.
Qed.

Ltac destTOf Γ e :=
    destruct (typeOf Γ e) as [[ | | | ? | ? ?] | ?] eqn:?; try easy.

Ltac destTOf' :=
  match goal with
  H: context [typeOf ?Γ ?e] |- _ => idtac e; destTOf Γ e
  end.

Ltac destTOf''' :=
  match goal with
  | H: context [match typeOf ?Γ ?e with Some _ => _ | None => _ end] |- _ =>
     idtac e; destruct (typeOf Γ e) eqn:?; try easy
  | H: context [match typeOf ?Γ ?e with Some _ => _ | _ => _ end] |- _ =>
     idtac e; destTOf Γ e
  end.

(*
** 'typeOf' is correct (part 2)
*)
Lemma typeOfCorrect'' : forall Γ e T, typeOf Γ e = Some T -> Γ |p= e : T.
Proof.
  intros * Heq.
  generalize dependent Γ.
  generalize dependent T.
  induction e; intros * Heq; subst;
  simpl in Heq; inversion Heq; subst; eauto using PTyping;
  try (destTOf Γ e1; destTOf Γ e2;
    inversion Heq; subst; eauto using PTyping; fail).
  - (* Set *)
    destTOf'.
    destTOf'.
    repeat destTOf'''.
    destruct (dec_TP p p0) eqn:?; try easy.
    inversion Heq; subst. eauto using PTyping.
  - (* App *)
    destTOf'.
    destTOf'''.
    destruct (dec_TP p p1) eqn:?; try easy.
    inversion Heq; subst. eauto using PTyping.
  - (* Fun *)
    destTOf'''.
    destruct (dec_TP p0 p1); subst; try discriminate.
    inversion Heq; subst. eauto using PTyping.
  - (* Let *)
    repeat destTOf'''.
    destruct (dec_TP p p0); subst; try easy.
    inversion Heq; subst. eauto using PTyping.
  - (* Cast *)
    destTOf'''.
    inversion Heq; subst. eauto using PTyping.
Qed.

(*
** Rules and algorithm agree
*)
Lemma typeOfCorrect : forall Γ e T, typeOf Γ e = Some T <-> Γ |p= e : T.
Proof. split; auto using typeOfCorrect', typeOfCorrect''. Qed.

(*
** Pallene types are unique
*)
Lemma PTypeUnique : forall Γ e t1 t2,
    Γ |p= e : t1 -> Γ |p= e : t2 -> t1 = t2.
Proof.
  intros * H1 H2.
  apply typeOfCorrect in H1.
  apply typeOfCorrect in H2.
  congruence.
Qed.

Lemma PinclusionType : forall Γ Γ' e T,
  Γ |p= e : T ->
  inclusion Γ Γ' ->
  Γ' |p= e : T.
Proof.
  intros * HTy HIn.
  generalize dependent Γ'.
  induction HTy; intros; eauto using PTyping, inclusion_update.
Qed.

Lemma PinclusionEmpty : forall Γ e T,
  MEmpty |p= e : T ->
  Γ |p= e : T.
Proof.
  eauto using PinclusionType, inclusion_empty.
Qed.

(*
** Pallene values
*)
Inductive PValue : PE -> Prop :=
| PVnil : PValue PENil
| PVnum : forall n, PValue (PENum n)
| PVtbl : forall a T, PValue (PETAddr a T)
| PVfun : forall a T1 T2, PValue (PEFAddr a T1 T2)
| PVbox : forall v, PValue v -> PValue (PECast v PTStar)
.

(* Canonical forms *)

Lemma ValStar : forall v,
  PValue v ->
  MEmpty |p= v : PTStar ->
  exists v', v = PECast v' PTStar /\ PValue v'.
Proof.
  intros * HV HT. inversion HT; subst; inversion HV; subst; eauto.
Qed.

Lemma ValNil : forall v,
  PValue v ->
  MEmpty |p= v : PTNil ->
  v = PENil.
Proof.
  intros * HV HT. inversion HT; subst; inversion HV; subst; eauto.
Qed.

Lemma ValInt : forall v,
  PValue v ->
  MEmpty |p= v : PTInt ->
  exists n, v = PENum n.
Proof.
  intros * HV HT. inversion HT; subst; inversion HV; subst; eauto.
Qed.

Lemma ValArr : forall v T,
  PValue v ->
  MEmpty |p= v : PTArr T ->
  exists a, v = PETAddr a T.
Proof.
  intros * HV HT. inversion HT; subst; inversion HV; subst; eauto.
Qed.

Lemma ValFun : forall v T1 T2,
  PValue v ->
  MEmpty |p= v : PTFun T1 T2 ->
  exists a, v = PEFAddr a T1 T2.
Proof.
  intros * HV HT. inversion HT; subst; inversion HV; subst; eauto.
Qed.

(*
** Cast a Pallene expression to a given type; gives None iff cast
** fails.
*)
Fixpoint PCast (e : PE) (T : PType) : option PE :=
  match e, T with
  | PECast e' PTStar, PTStar => Some e		(* '*' to '*' *)
  | PECast e' PTStar, T => PCast e' T		(* downcast from '*' *)
  | e', PTStar => Some (PECast e' PTStar)	(* upcast to '*' *)
  | PENil, PTNil => Some e
  | PENum n, PTInt => Some e
  | PETAddr a T, PTArr T' => Some (PETAddr a T')
  | PEFAddr a T1 T2, PTFun T1' T2' => Some (PEFAddr a T1' T2')
  | _, _ => None
  end.

(*
** The cast of a value gives a value
*)
Lemma CastValue : forall e v T,
  PValue e ->
  PCast e T = Some v ->
  PValue v.
Proof.
  intros * PV PC.
  induction PV; destruct T; simpl in *;
   try discriminate;
   try (injection PC; intros; subst); auto using PValue.
Qed.

(*
** A successful cast of a value to a type has that type
*)
Lemma CastEqType : forall e T1 T2 v,
  PValue e ->
  MEmpty |p= e : T1 ->
  PCast e T2 = Some v ->
  MEmpty |p= v : T2.
Proof.
  intros * HV HT HC.
  remember MEmpty as Gamma eqn:HEq.
  induction HT; inversion HV; subst;
  destruct T2; simpl in *; try discriminate;
  try (injection HC; intros; subst); eauto using PTyping.
Qed.

(*
** A cast of a value to its own type gives the value itself
*)
Lemma CastToItsType : forall T v,
  PValue v ->
  MEmpty |p= v : T ->
  PCast v T = Some v.
Proof.
  intros * HV HT.
  induction HV; inversion HT; trivial.
Qed.

(*
** A cast to '*' never fails
*)
Lemma CastToStar : forall e, exists e', PCast e PTStar = Some e'.
Proof.
  induction e; try (eexists; simpl; eauto; fail).
  destruct IHe.
  destruct p;
  simpl; eauto.
Qed.

Definition PToIndex (n : nat) : lir.Index := lir.I n lir.TgInt.

Inductive PExpValue : Set :=
| PEV : forall e, PValue e -> PExpValue.

Ltac DExpValue := match goal with E: PExpValue |- _ => destruct E end.

Definition PEV2Val (me : PExpValue) : PE :=
  match me with
  | PEV v _ => v
  end.

Inductive PMem : Set :=
| PEmptyMem : PMem
| PUpdateT : lir.address -> lir.Index -> PExpValue -> PMem -> PMem
| PUpdateF : lir.address -> string -> PType -> PE -> PMem -> PMem.

(* [nil as *] *)
Definition NilStar : PE := PECast PENil PTStar.

(* Proof object that [nil as *] is a value *)
Definition NilStarVal : PValue NilStar := PVbox PENil PVnil.

Fixpoint PqueryT (a : lir.address) (idx : nat) (m : PMem) : PE :=
  match m with
  | PEmptyMem => NilStar
  | PUpdateT a' idx' e m' => if Nat.eq_dec a a' then
                           if lir.Index_dec (PToIndex idx) idx' then (PEV2Val e)
                           else PqueryT  a idx m'
                         else PqueryT  a idx m'
  | PUpdateF _ _ _ _ m' => PqueryT a idx m'
  end.

Fixpoint PqueryF (a : lir.address) (m : PMem) : (string * PType * PE) :=
  match m with
  | PEmptyMem => (""%string, PTStar,  NilStar)
  | PUpdateT a' _ _ m' => PqueryF a m'
  | PUpdateF a' var type body m' => if Nat.eq_dec a a' then (var, type,  body)
                                    else PqueryF a m'
  end.

Fixpoint Pfreshaux (m : PMem) : lir.address :=
  match m with
  | PEmptyMem => 1
  | PUpdateT _ _ _ m' => S (Pfreshaux m')
  | PUpdateF _ _ _ _ m' => S (Pfreshaux m')
  end.

Definition PfreshT (m : PMem) : (lir.address * PMem) :=
  let f := Pfreshaux m in
    (f, PUpdateT f (lir.I 0 lir.TgNil) (PEV NilStar NilStarVal) m).

Definition PfreshF (m : PMem) (v : string) (t : PType) (b : PE) :
             (lir.address * PMem) :=
  let f := Pfreshaux m in
    (f, PUpdateF f v t (PECast b PTStar) m).

Reserved Notation "'[' x ':=' s ']p' t" (at level 20, x constr).

Fixpoint substitution (var : string) (y : PE)  (e : PE) : PE :=
 match e with
 | PENil => e
 | PENum n => e
 | PEPlus e1 e2 => PEPlus ([var := y]p e1) ([var := y]p e2)
 | PENew _ => e
 | PETAddr a _ => e
 | PEFAddr a _ _ => e
 | PEGet e1 e2 => PEGet ([var := y]p e1) ([var := y]p e2)
 | PESet e1 e2 e3 => PESet ([var := y]p e1) ([var := y]p e2) ([var := y]p e3)
 | PEVar var' => if string_dec var var' then y else e
 | PEFun var' T1 body T2 => if string_dec var var' then e
                          else PEFun var' T1 ([var := y]p body) T2
 | PELet var' Tvar init body =>
     if string_dec var var'
       then PELet var' Tvar ([var := y]p init) body
       else PELet var' Tvar ([var := y]p init) ([var := y]p body)
 | PEApp e1 e2 => PEApp ([var := y]p e1) ([var := y]p e2)
 | PECast e T => PECast ([var := y]p e) T
end
where "'[' x ':=' s ']p' t" := (substitution x s t)
.

(*
** Extending an environment preserves typing
*)
Lemma Pinclusion_typing : forall Γ Γ' e te,
  inclusion Γ Γ' -> Γ |p= e : te -> Γ' |p= e : te.
Proof.
  intros * Hin Hty.
  generalize dependent Γ'.
  induction Hty; eauto using PTyping, inclusion_update.
Qed.

(*
** Particular case when extending the empty environment
*)
Lemma Ptyping_empty : forall Γ e te, MEmpty |p= e : te -> Γ |p= e : te.
Proof.
  eauto using Pinclusion_typing, inclusion_empty.
Qed.

(*
** Substitution preserves typing
*)
Lemma Psubst_typing : forall e2 Γ var tv te e1,
  (var |=> tv; Γ) |p= e2 : te ->
  MEmpty |p= e1 : tv ->
       Γ |p= ([var := e1]p e2) : te.
Proof.
  induction e2; intros * HT2 HT1;
  simpl; inversion HT2; subst;
  breakStrDec;
  try match goal with H: Some ?e = Some ?e' |- _ =>
    replace e' with e in * by congruence
  end;
  eauto 6 using Pinclusion_typing, inclusion_shadow, inclusion_permute,
    PTyping, Ptyping_empty, InNotEq.
Qed.

Definition setTable (m : PMem) (a : lir.address) (idx : nat) (v : PE)
                    (Vv : PValue v) : PMem :=
        PUpdateT a (PToIndex idx) (PEV (PECast v PTStar) (PVbox v Vv)) m.

(*
** Evaluation steps for Lir expressions
*)
Reserved Notation "m '/' e '-p->' m1 '/' e1"
(at level 40, e at level 39, m1 at level 39, e1 at level 39).
Reserved Notation "m '/' e '-p->' 'fail'"
(at level 40, e at level 39).

Inductive pstep : PMem -> PE -> PMem -> PE -> Prop :=
| PStPlus1 : forall m e1 e2 m' e1',
    m / e1 -p-> m' / e1' ->
    m / PEPlus e1 e2 -p-> m' / PEPlus e1' e2
| PStPlus2 : forall m e1 e2 m' e2',
    PValue e1 ->
    m / e2 -p-> m' / e2' ->
    m /  PEPlus e1 e2 -p-> m' /  PEPlus e1 e2'
| PStPlus : forall m n1 n2,
    m /  PEPlus (PENum n1) (PENum n2) -p-> m /  PENum (n1 + n2)
| PStNew : forall m m' free T,
    (free, m') = PfreshT m ->
    m / PENew T -p-> m' / PETAddr free T
| PStGet1 : forall m e1 e2 m' e1',
    m /e1 -p-> m' /e1' ->
    m / PEGet e1 e2 -p-> m' / PEGet e1' e2
| PStGet2 : forall m e1 e2 m' e2',
    PValue e1 ->
    m /e2 -p-> m' /e2' ->
    m / PEGet e1 e2 -p-> m' / PEGet e1 e2'
| PStGet : forall m a idx T,
    m / PEGet (PETAddr a T) (PENum idx) -p-> m / PECast (PqueryT a idx m) T
| PStSet1 : forall m e1 e2 e3 m' e1',
    m / e1 -p-> m' / e1' ->
    m / PESet e1 e2 e3 -p-> m' / PESet e1' e2 e3
| PStSet2 : forall m e1 e2 e3 m' e2',
    PValue e1 ->
    m / e2 -p-> m' / e2' ->
    m / PESet e1 e2 e3 -p-> m' / PESet e1 e2' e3
| PStSet3 : forall m e1 e2 e3 m' e3',
    PValue e1 -> PValue e2 ->
    m / e3 -p-> m' / e3' ->
    m / PESet e1 e2 e3 -p-> m' / PESet e1 e2 e3'
| PStSet : forall m a idx v T (Vv : PValue v),
    PValue v ->  (* shouldn't be necessary, but otherwise it is shelved *)
    m / PESet (PETAddr a T) (PENum idx) v -p-> setTable m a idx v Vv / PENil
| PStFun : forall m m' v b free T1 T2,
    (free, m') = PfreshF m v T1 b ->
    m / PEFun v T1 b T2 -p-> m' / PEFAddr free T1 T2
| PStLet1 : forall m m' init init' body var TV,
    m / init -p-> m' / init' ->
    m / PELet var TV init body -p-> m' / PELet var TV init' body
| PStLet : forall m init body var TV,
  PValue init ->
  m / PELet var TV init body -p-> m / ([var := init]p body)
| PStApp1 : forall m e1 e2 m' e1',
    m / e1 -p-> m' / e1' ->
    m / PEApp e1 e2 -p-> m' / PEApp e1' e2
| PStApp2 : forall m e1 e2 m' e2',
    PValue e1 ->
    m / e2 -p-> m' / e2' ->
    m / PEApp e1 e2 -p-> m' / PEApp e1 e2'
| PStApp : forall m a var type body v T1 T2,
    PValue v ->
    (var, type, body) = PqueryF a m ->
    m / PEApp (PEFAddr a T1 T2) v -p->
          m / PECast (PELet var type (PECast v type) body) T2
| PStCast1 : forall m e m' e' T,
    m / e -p-> m' / e' ->
    m / PECast e T -p-> m' / PECast e' T
| PStCast : forall m T v v',
    PValue v ->
    T <> PTStar ->
    PCast v T = Some v' ->
    m / PECast v T -p-> m / v'

where "m / e -p-> m1 / e1" := (pstep m e m1 e1).

(*
** Fail evaluation for Pallene expressions
*)
Inductive pstepF : PMem -> PE -> Prop :=
| PStPlus1F : forall m e1 e2,
    m / e1 -p-> fail ->
    m / PEPlus e1 e2 -p-> fail
| PStPlus2F : forall m e1 e2,
    PValue e1 ->
    m / e2 -p-> fail ->
    m /  PEPlus e1 e2 -p-> fail
| PStGet1F : forall m e1 e2,
    m /e1 -p-> fail ->
    m / PEGet e1 e2 -p-> fail
| PStGet2F : forall m e1 e2,
    PValue e1 ->
    m /e2 -p-> fail ->
    m / PEGet e1 e2 -p-> fail
| PStSet1F : forall m e1 e2 e3,
    m / e1 -p-> fail ->
    m / PESet e1 e2 e3 -p-> fail
| PStSet2F : forall m e1 e2 e3,
    PValue e1 ->
    m / e2 -p-> fail ->
    m / PESet e1 e2 e3 -p-> fail
| PStSet3F : forall m e1 e2 e3,
    PValue e1 -> PValue e2 ->
    m / e3 -p-> fail ->
    m / PESet e1 e2 e3 -p-> fail
| PStLet1F : forall m init body var TV,
    m / init -p-> fail ->
    m / PELet var TV init body -p-> fail
| PStApp1F : forall m e1 e2,
    m / e1 -p-> fail ->
    m / PEApp e1 e2 -p-> fail
| PStApp2F : forall m e1 e2,
    PValue e1 ->
    m / e2 -p-> fail ->
    m / PEApp e1 e2 -p-> fail
| PStCast1F : forall m t e,
    m / e -p-> fail ->
    m / PECast e t -p-> fail
| PStCastF : forall m T v,
    PValue v ->
    PCast v T = None ->
    m / PECast v T -p-> fail

 where "m / e -p-> 'fail'" := (pstepF m e)
.

Lemma ValueNormal : forall v m,
  PValue v ->
  ~exists e' m', m / v -p-> m' / e'.
Proof.
  intros * HV [e' [m' H]].
  induction H; inversion HV; subst; eauto.
Qed.

Lemma ValueNormalF : forall v m,
  PValue v ->
  ~m / v -p-> fail.
Proof.
  intros * HV HF.
  induction HF; inversion HV; subst; eauto.
  specialize (CastToStar v) as [? ?].
  congruence.
Qed.

(*
** Ensures that all elements of tables and all "functions" in a
** memory are well typed.
*)
Inductive Pmem_correct : PMem -> Prop :=
| PMCE : Pmem_correct PEmptyMem
| PMCT : forall a idx v m,
     MEmpty |p= PEV2Val v : PTStar ->
     Pmem_correct m ->
     Pmem_correct (PUpdateT a idx v m)
| PMCF : forall a var type body m,
     (var |=> type; MEmpty) |p= body : PTStar ->
     Pmem_correct m ->
     Pmem_correct (PUpdateF a var type body m)
.

(*
** All expressions stored in memory tables are values
*)
Lemma PMCValue : forall m a n, PValue (PqueryT a n m).
Proof.
  unfold PqueryT.
  intros.
  induction m; try DExpValue; lir.breakIndexDec; eauto using PValue.
Qed.

(*
** All expressions stored in a table of a correct memory are
** well typed
*)
Lemma PMCTy : forall m a n Γ,
    Pmem_correct m ->
    Γ |p= (PqueryT a n m) : PTStar.
Proof.
  unfold PqueryT.
  induction 1; lir.breakIndexDec; eauto using PTyping, Ptyping_empty.
Qed.

(*
** All functions stored in a correct memory have correct types.
*)
Lemma PMCTyF : forall m a var type body Γ,
    (var, type,  body) = PqueryF a m ->
    Pmem_correct m ->
    (var |=> type; Γ) |p= body : PTStar.
Proof.
  intros * HEq HMC.
  induction HMC; simpl in HEq;
    lir.breakIndexDec; try (injection HEq; intros; subst);
    eauto using PTyping, Pinclusion_typing, inclusion_update, inclusion_empty.
Qed.

(*
** Table allocation preserves memory correctness
*)
Lemma Pmem_correct_freshT : forall m m' free,
  Pmem_correct m -> (free,m') = PfreshT m -> Pmem_correct m'.
Proof.
  inversion 2.
  eauto using Pmem_correct, PTyping.
Qed.

(*
** Function allocation preserves memory correctness
*)
Lemma Pmem_correct_freshF : forall m m' var T1 T2 body free,
  (var |=> T1; MEmpty) |p= body : T2 ->
  Pmem_correct m ->
  (free,m') = PfreshF m var T1 body ->
  Pmem_correct m'.
Proof.
  inversion 3; subst.
  eauto using Pmem_correct, PTyping.
Qed.

Lemma memCorrectSet : forall a idx v (Vv: PValue v) T m,
  MEmpty |p= v : T ->
  Pmem_correct m ->
  Pmem_correct (setTable m a idx v Vv).
Proof.
  eauto using Pmem_correct, PTyping.
Qed.

(*
** Executing an evaluation step preserves memory
** correctness
*)
Lemma PmemPreservation : forall (m m' : PMem) e e' t,
  Pmem_correct m ->
  MEmpty |p= e : t ->
  m / e -p-> m' / e' ->
  Pmem_correct m'.
Proof.
  intros * HMC HTy Hst.
  generalize dependent m'.
  generalize dependent e'.
  remember MEmpty as Γ.
  induction HTy; intros * Hst; inversion Hst; subst;
  eauto using Pmem_correct_freshT, Pmem_correct_freshF, Pmem_correct,
              memCorrectSet.
Qed.

(*
** Preservation of types for Pallene expressions
*)
Theorem PexpPreservation : forall m e t m' e',
  Pmem_correct m ->
  MEmpty |p= e : t ->
  m / e -p-> m' / e' ->
  MEmpty |p= e' : t.
Proof.
  intros m e t m' e' Hmc HT.
  generalize dependent m'.
  generalize dependent e'.
  remember MEmpty as Γ.
  induction HT; intros * Hst; inversion Hst; subst;
  eauto using PTyping, PMCTy, PMCTyF, Psubst_typing, CastEqType;
  inversion HT1; subst;
    eauto using PTyping, PMCTy, PMCTyF, PMCValue.
Qed.

(*
** Preservation of types for Pallene expressions,
** function version.
*)
Lemma PexpPreservTypeOf : forall m e t m' e',
  Pmem_correct m ->
  MEmpty |p= e : t ->
  m / e -p-> m' / e' ->
  typeOf MEmpty e = typeOf MEmpty e'.
Proof.
  intros * PM PTy PSt.
  erewrite typeOfCorrect'; eauto.
  erewrite typeOfCorrect'; eauto.
  eauto using PexpPreservation.
Qed.

Ltac openCanonicValue rule :=
  repeat match goal with
    | [ Ht : MEmpty |p= ?e : _,
        Hv : PValue ?e |- _] =>
          eapply rule in Ht; trivial; decompose [ex or and] Ht; clear Ht
    end.

Ltac dostep :=
  right; only 1: (right; eauto using pstep); left;  eauto using pstepF.

(*
** Progress for Pallene terms
*)
Theorem Progress : forall m e t,
    MEmpty |p= e : t  ->
    PValue e \/
    (m / e -p-> fail \/ exists m' e', m / e -p-> m' / e').
Proof.
  intros m e t Hty.
  remember MEmpty as Γ eqn:Heq.
  generalize dependent m.
  induction Hty; intros m; subst;

  (* handle values *)
    try (left; auto using PValue; fail);

  (* handle variables (no variables in an empty environment) *)
  try match goal with
  | [ H: In MEmpty _ = Some _ |- _] => inversion H
  end;

  (* instantiate and break induction hypotheses *)
  repeat match goal with
    | [H: ?E = ?E -> _ |- _] =>
      specialize (H eq_refl m) as [? | [? | [? [? ?]]]]
  end;

  (* instantiate canonic forms *)
  openCanonicValue ValInt;
  openCanonicValue ValArr;
  openCanonicValue ValFun;
  subst;

  (* handle fails *)
  try (eauto using pstepF; fail);

  (* handle easy step cases *)
  try (unshelve (right; right; subst; eauto using pstep); trivial; fail).

  (* Each of the next cases needs some very specific destructs *)

  - (* New *)
    pose (PfreshT m) as P. destruct P eqn:?;
    dostep.

  - (* Fun *)
    pose (PfreshF m var Tvar body) as P; destruct P eqn:?;
    dostep.

  - (* App *)
    pose (PqueryF x m) as P. destruct P as [[? ?] ?] eqn:?; subst.
    dostep.

  - (* Cast *)
    destruct (dec_TP T2 PTStar) eqn:?; subst.
    + (* upcast *) left. eauto using PValue.
    + (* downcast *) destruct (PCast e T2) eqn:?;
      dostep.

Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_sha_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 ss2, T2 = (t_sha_top x2 L2 ss2) ->
                                  subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.