(** ** Basic definitions for substiutions *)

(* Version: 19.09. *)

From FOL Require Export axioms.

Notation fin := nat.
Definition shift  := S.

Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
          |0 => x
          |S n => xi n
          end.

Notation "s .: sigma" := (scons s sigma) (at level 70).

Definition var_zero := 0.

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

(* **** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Declare Scope subst_scope.
Declare Scope fscope.

Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(* **** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

Class Var X Y :=
  ids : X -> Y.

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (*fun x => g (f x)*) (at level 50) : subst_scope.
Open Scope subst_scope.

Definition up_ren (xi : nat -> nat) :=
  0 .: (xi >> S).

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [|x].
  - reflexivity.
  - unfold up_ren. simpl. unfold funcomp. rewrite <- E. reflexivity.
Qed.

Definition id {X} (x: X) := x.

Lemma scons_eta {T} (f : nat -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (nat -> nat).
Proof. fext. intros [|x]; reflexivity. Qed.

Lemma scons_comp (T: Type) U (s: T) (sigma: nat -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = scons (tau s) (sigma >> tau) .
Proof.
  fext. intros [|x]; reflexivity.
Qed.

Ltac fsimpl :=
  unfold up_ren; repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) (* AsimplComp *)
         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma)var_zero) with s
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h))
        | [|- context[?f >> (?x .: ?g)]] =>
           change (f >> (x .: g)) with g
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: shift >> ?f]] =>
           change x2 with (f 0); rewrite (@scons_eta _ _ f)
         | [|- context[(?v .: ?g) 0]] =>
           change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] =>
           change ((v .: g) (S n)) with (g n)
         | [|- context[?f 0 .: ?g]] =>
           change g with (shift >> f); rewrite scons_eta
         | _ => first [progress (rewrite ?scons_comp) | progress (rewrite ?scons_eta_id)]
 end.

Ltac fsimplc :=
  unfold up_ren; repeat match goal with
         | [H : context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id] |- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s] |- _]  => change (id s) with s in H
         | [H:  context[(?f >> ?g) >> ?h]  |- _] =>
           change ((?f >> ?g) >> ?h) with (f >> (g >> h)) in H(* AsimplComp *)
         | [H : context[(?s.:?sigma) var_zero]  |- _] => change ((s.:sigma)var_zero) with s in H
         | [H: context[(?f >> ?g) >> ?h]  |- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H
        | [H: context[?f >> (?x .: ?g)]  |- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[var_zero]  |- _] =>  change var_zero with 0 in H
         | [H: context[?x2 .: shift >> ?f]  |- _] =>
           change x2 with (f 0) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[(?v .: ?g) 0]  |- _] =>
           change ((v .: g) 0) with v in H
         | [H: context[(?v .: ?g) (S ?n)]  |- _] =>
           change ((v .: g) (S n)) with (g n) in H
         | [H: context[?f 0 .: ?g]  |- _] =>
           change g with (shift >> f); rewrite scons_eta in H
         | _ => first [progress (rewrite ?scons_comp in *)  | progress (rewrite ?scons_eta_id in *) ]
 end.

Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

(* **** Notations *)

(* Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope. *)

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.
Instance idsRen : Var nat nat := id.

Notation "↑" := (shift).

Ltac auto_unfold := unfold subst1, ren1, subst2, ren2, ids; unfold Subst1, Ren1, Subst2, Ren2, Var.

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : nat), _] => intros []; t
                                           end).

    Ltac unfold_funcomp := match goal with
                           | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                           end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive color :=
  | Blue : color
  | White : color
  | Red : color.
Axiom color_WhyType : WhyType color.
Existing Instance color_WhyType.

(* Why3 assumption *)
Definition monochrome (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (c:color): Prop := forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) ->
  ((map.Map.get a k) = c).

Parameter nb_occ: (map.Map.map Z color) -> Z -> Z -> color -> Z.

Axiom nb_occ_null : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  (j <= i)%Z -> ((nb_occ a i j c) = 0%Z).

Axiom nb_occ_add_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j
  c) = ((nb_occ a i (j - 1%Z)%Z c) + 1%Z)%Z).

Axiom nb_occ_add_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (c:color), ((i < j)%Z /\ ~ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a
  i j c) = (nb_occ a i (j - 1%Z)%Z c)).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 3; admit.

(* Why3 goal *)
Theorem nb_occ_split : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ a i k c) = ((nb_occ a i j
  c) + (nb_occ a j k c))%Z).
(* Why3 intros a i j k c (h1,h2). *)
intros a i j k c (h1 & h2).
generalize h2.
pattern k; apply Zlt_lower_bound_ind with (z:=j); auto.
ae.
Admitted.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Generate a symbol distinct from every element of a list of symbols *)
(** Assumes a way to generate a new symbol from a pair of symbols "greater" than either one. *)
Require Import Coq.Classes.RelationClasses Coq.Lists.List Coq.ZArith.ZArith.
Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Common.StringFacts.

Set Implicit Arguments.

Class PreGensym A :=
  { s_gt : A -> A -> Prop;
    sym_init : A;
    combine_symbols : A -> A -> A;
    s_gt_Asymmetric :> Asymmetric s_gt;
    s_gt_Transitive :> Transitive s_gt;
    combine_respectful_l : forall x y, s_gt (combine_symbols x y) x;
    combine_respectful_r : forall x y, s_gt (combine_symbols x y) y }.

Delimit Scope gensym_scope with gensym.
Infix ">" := s_gt : gensym_scope.

Fixpoint gensym {A} {H : PreGensym A} (used : list A) : A
  := match used with
       | nil => sym_init
       | cons x xs => combine_symbols x (gensym xs)
     end.

Lemma gensym_gt {A} {H : PreGensym A} (ls : list A)
: forall x, List.In x ls -> (gensym ls > x)%gensym.
Proof.
  intro x.
  induction ls as [|l ls IHls]; simpl.
  { intros []. }
  { intros [H'|H']; subst.
    { apply combine_respectful_l. }
    { etransitivity; [ apply combine_respectful_r | ].
      apply IHls, H'. } }
Qed.

Lemma gensym_fresh {A} {H : PreGensym A} (ls : list A)
: ~List.In (gensym ls) ls.
Proof.
  intro H'.
  apply gensym_gt in H'.
  apply asymmetry in H'; assumption.
Qed.

Global Program Instance gensym_nat : PreGensym nat
  := { s_gt := gt;
       sym_init := 0;
       combine_symbols x y := S (x + y) }.
Next Obligation.
  repeat intro; abstract omega.
Defined.
Next Obligation.
  repeat intro; abstract omega.
Defined.
Next Obligation.
  repeat intro; abstract omega.
Defined.
Next Obligation.
  repeat intro; abstract omega.
Defined.

Global Program Instance gensym_string : PreGensym string
  := { s_gt x y := gt (length x) (length y);
       sym_init := ""%string;
       combine_symbols x y := String.String "a"%char (x ++ y)%string }.
Next Obligation.
  repeat intro; abstract omega.
Defined.
Next Obligation.
  repeat intro; abstract omega.
Defined.
Next Obligation.
  simpl; repeat intro; abstract (rewrite concat_length; omega).
Defined.
Next Obligation.
  simpl; repeat intro; abstract (rewrite concat_length; omega).
Defined.


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

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        LamSF_Cube.v                                *)
(*                                                                    *)
(* adapted from Cube.v for Lambda Calculus                            *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import LamSF_Terms.
Require Import General.
Require Import Beta_Reduction.
Require Import LamSF_Redexes.
Require Import Test.
Require Import LamSF_Substitution.
Require Import LamSF_Residuals.

(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall i, compat (Var i) (Var i) (Var i)
  | Compat_Oper : forall o, compat (Opp o) (Opp o) (Opp o)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall (b : bool), compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 ,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall (b b' : bool),
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2)
  | Compat_Fun :
      forall U V W, compat U V W -> compat (Fun U) (Fun V) (Fun W)
.

Hint Resolve Compat_Var Compat_Oper Compat_Ap1 Compat_Ap2 Compat_Fun.

Lemma compat_intro :
 forall U W WU : redexes,
 residuals W U WU ->
 forall (V WV : redexes) (R2 : residuals W V WV) (S : sub V U), compat U V W.
Proof.
(* Remark use of name R2 for uniform command below *)
simple induction 1; intros; generalize S; inversion_clear R2; intros;
 inversion_clear S; split_all; eauto.

inversion_clear S0.  eapply2 Compat_Ap1.
inversion_clear S0.
inversion_clear S0. eapply2 Compat_Fun.
inversion_clear S0.
inversion_clear H6. gen_inv H4 H8. subst. eapply2 Compat_Ap2. inversion H12; split_all. eapply2 H1.

inversion S0; subst; split_all.
inversion H11; subst.
inversion H4; subst.
eapply2 Compat_Ap2.

inversion H6; subst.
inversion S0; subst. inversion H12; subst.
eapply2 Compat_Ap2.

inversion H6; subst.
inversion S0; subst. inversion H12; subst.
eapply2 Compat_Ap2.
Qed.

Lemma prism0 :
 forall U V W : redexes,
 compat U V W ->
 forall (UV : redexes) (R1 : residuals U V UV) (WU WV : redexes)
   (R2 : residuals W U WU) (R3 : residuals W V WV),
 residuals WV UV WU.
Proof.
simple induction 1;
try (intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; eauto; fail).
intros.
gen3_case R1 R2 R3 b.

inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
unfold subst_r. eapply2 residuals_subst_rec.

inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
inversion_clear H4; inversion_clear H8; auto.
Qed.

(* Remark - It should be possible to get rid of auxiliary compat
   and to combine prism0 with compat_intro in one lemma *)

(*****************************************************************)
(* Theorem prism : (U,V,W:redexes)(sub V U) ->                   *)
(*     (UV:redexes)(residuals U V UV) ->                         *)
(*     (WV:redexes)(residuals W V WV) ->                         *)
(*     (WU:redexes)(residuals W U WU) <-> (residuals WV UV WU).  *)
(*****************************************************************)

Lemma prism1 :
 forall U V W : redexes,
 sub V U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals W U WU -> residuals WV UV WU.
Proof.
intros; apply prism0 with U V W; auto.
apply compat_intro with WU WV; trivial.
Qed.

(* Converse of prism1 but needs regularity of U *)
Lemma prism2 :
 forall U V W : redexes,
 sub V U ->
 regular U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals WV UV WU -> residuals W U WU.
Proof.
intros.
elim (residuals_intro W U); trivial.
intros WU' R; elim (residuals_function WV UV WU) with WU'; trivial.
apply prism1 with U V W; trivial.
apply comp_trans with V.
apply residuals_comp with WV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
Qed.

Theorem prism :
 forall U V W : redexes,
 sub V U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals W U WU <-> regular U /\ residuals WV UV WU.
Proof.
intros; unfold iff in |- *; split.
intro; split.
apply residuals_regular with W WU; trivial.
apply prism1 with U V W; trivial.
simple induction 1; intros; apply prism2 with V UV WV; trivial.
Qed.

(**************************************************************************)
(*  Levy's cube lemma :                                                   *)
(*  (U,V,UV,VU:redexes)  (residuals U V UV) -> (residuals V U VU) ->      *)
(*  (W,WU,WV,WUV:redexes)(residuals W U WU) -> (residuals WU VU WUV) ->   *)
(*                       (residuals W V WV) -> (residuals WV UV WUV).     *)
(**************************************************************************)

Lemma cube :
 forall U V UV VU : redexes,
 residuals U V UV ->
 residuals V U VU ->
 forall W WU WV WUV : redexes,
 residuals W U WU ->
 residuals WU VU WUV -> residuals W V WV -> residuals WV UV WUV.
Proof.
intros.
cut (comp U V).
2: apply residuals_comp with UV; trivial.
intro C; elim (union_defined U V C); intros T UVT.
apply prism1 with T V W; trivial.
apply union_r with U; trivial.
apply preservation with U; trivial.
apply prism2 with U VU WU; trivial.
apply union_l with V; trivial.
apply union_preserve_regular with U V; trivial.
apply residuals_regular with V VU; trivial.
apply residuals_regular with U UV; trivial.
apply preservation with V; trivial.
apply union_sym; trivial.
Qed.

(* 3-dimensional paving diagram *)
Lemma paving :
 forall U V W WU WV : redexes,
 residuals W U WU ->
 residuals W V WV ->
 exists UV : redexes,
   (exists VU : redexes,
      (exists WUV : redexes, residuals WU VU WUV /\ residuals WV UV WUV)).
Proof.
intros; elim (residuals_intro U V).
intros UV R1; exists UV.
elim (residuals_intro V U).
intros VU R2; exists VU.
elim (residuals_intro WU VU).
intros WUV R3; exists WUV.
split; trivial.
apply cube with U V VU W WU; trivial.
apply mutual_residuals_comp with U W V; trivial.
apply residuals_preserve_regular with V U; trivial.
apply residuals_regular with U UV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
apply residuals_regular with W WU; trivial.
apply comp_trans with W.
apply comp_sym; apply residuals_comp with WU; trivial.
apply residuals_comp with WV; trivial.
apply residuals_regular with W WV; trivial.
Qed.


From mathcomp Require Import ssreflect ssrfun.
From Coq Require Export ssrbool.

(* 8.11 addition in Coq but renamed *)
#[deprecated(since="mathcomp 1.15", note="Use rel_of_simpl instead.")]
Notation rel_of_simpl_rel := rel_of_simpl.

(******************************************************************************)
(* Local additions:                                                           *)
(*        [in A] == the applicative counterpart of a collective predicate A:  *)
(*                  [in A] x beta-expands to x \in A. This is similar to      *)
(*                  mem A, except that mem A x only simplfies to x \in A.     *)
(* --> These will become part of the core SSReflect library in later Coq      *)
(* versions.                                                                  *)
(*   For the sake of backwards compatibility, this file also replicates       *)
(* v8.13-15 additions, including a generalization of the statments of         *)
(* `homoRL_in`, `homoLR_in`, `homo_mono_in`, `monoLR_in`, `monoRL_in`, and    *)
(* `can_mono_in`.                                                             *)
(******************************************************************************)

(*******************)
(* v8.13 additions *)
(*******************)

Section HomoMonoMorphismFlip.
Variables (aT rT : Type) (aR : rel aT) (rR : rel rT) (f : aT -> rT).
Variable (aD aD' : {pred aT}).

Lemma homo_sym : {homo f : x y / aR x y >-> rR x y} ->
  {homo f : y x / aR x y >-> rR x y}.
Proof. by move=> fR y x; apply: fR. Qed.

Lemma mono_sym : {mono f : x y / aR x y >-> rR x y} ->
  {mono f : y x / aR x y >-> rR x y}.
Proof. by move=> fR y x; apply: fR. Qed.

Lemma homo_sym_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} ->
  {in aD &, {homo f : y x / aR x y >-> rR x y}}.
Proof. by move=> fR y x yD xD; apply: fR. Qed.

Lemma mono_sym_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} ->
  {in aD &, {mono f : y x / aR x y >-> rR x y}}.
Proof. by move=> fR y x yD xD; apply: fR. Qed.

Lemma homo_sym_in11 : {in aD & aD', {homo f : x y / aR x y >-> rR x y}} ->
  {in aD' & aD, {homo f : y x / aR x y >-> rR x y}}.
Proof. by move=> fR y x yD xD; apply: fR. Qed.

Lemma mono_sym_in11 : {in aD & aD', {mono f : x y / aR x y >-> rR x y}} ->
  {in aD' & aD, {mono f : y x / aR x y >-> rR x y}}.
Proof. by move=> fR y x yD xD; apply: fR. Qed.

End HomoMonoMorphismFlip.
Arguments homo_sym {aT rT} [aR rR f].
Arguments mono_sym {aT rT} [aR rR f].
Arguments homo_sym_in {aT rT} [aR rR f aD].
Arguments mono_sym_in {aT rT} [aR rR f aD].
Arguments homo_sym_in11 {aT rT} [aR rR f aD aD'].
Arguments mono_sym_in11 {aT rT} [aR rR f aD aD'].

(******************)
(* v8.14 addtions *)
(******************)

Section LocalGlobal.

Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0).
Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0).

Variables T1 T2 T3 : predArgType.
Variables (D1 : {pred T1}) (D2 : {pred T2}).
Variables (f : T1 -> T2) (h : T3).
Variable Q1 : (T1 -> T2) -> T1 -> Prop.
Variable Q1l : (T1 -> T2) -> T3 -> T1 -> Prop.
Variable Q2 : (T1 -> T2) -> T1 -> T1 -> Prop.
Let allQ1 f'' := {all1 Q1 f''}.
Let allQ1l f'' h' := {all1 Q1l f'' h'}.
Let allQ2 f'' := {all2 Q2 f''}.

Lemma in_on1P : {in D1, {on D2, allQ1 f}} <->
                {in [pred x in D1 | f x \in D2], allQ1 f}.
Proof.
split => allf x; have /[!inE] Q1f := allf x; first by case/andP.
by move=> ? ?; apply: Q1f; apply/andP.
Qed.

Lemma in_on1lP : {in D1, {on D2, allQ1l f & h}} <->
                {in [pred x in D1 | f x \in D2], allQ1l f h}.
Proof.
split => allf x; have /[!inE] Q1f := allf x; first by case/andP.
by move=> ? ?; apply: Q1f; apply/andP.
Qed.

Lemma in_on2P : {in D1 &, {on D2 &, allQ2 f}} <->
                {in [pred x in D1 | f x \in D2] &, allQ2 f}.
Proof.
split => allf x y; have /[!inE] Q2f := allf x y.
  by move=> /andP[? ?] /andP[? ?]; apply: Q2f.
by move=> ? ? ? ?; apply: Q2f; apply/andP.
Qed.

Lemma on1W_in : {in D1, allQ1 f} -> {in D1, {on D2, allQ1 f}}.
Proof. by move=> D1f ? /D1f. Qed.

Lemma on1lW_in : {in D1, allQ1l f h} -> {in D1, {on D2, allQ1l f & h}}.
Proof. by move=> D1f ? /D1f. Qed.

Lemma on2W_in : {in D1 &, allQ2 f} -> {in D1 &, {on D2 &, allQ2 f}}.
Proof. by move=> D1f ? ? ? ? ? ?; apply: D1f. Qed.

Lemma in_on1W : allQ1 f -> {in D1, {on D2, allQ1 f}}.
Proof. by move=> allf ? ? ?; apply: allf. Qed.

Lemma in_on1lW : allQ1l f h -> {in D1, {on D2, allQ1l f & h}}.
Proof. by move=> allf ? ? ?; apply: allf. Qed.

Lemma in_on2W : allQ2 f -> {in D1 &, {on D2 &, allQ2 f}}.
Proof. by move=> allf ? ? ? ? ? ?; apply: allf. Qed.

Lemma on1S : (forall x, f x \in D2) -> {on D2, allQ1 f} -> allQ1 f.
Proof. by move=> ? fD1 ?; apply: fD1. Qed.

Lemma on1lS : (forall x, f x \in D2) -> {on D2, allQ1l f & h} -> allQ1l f h.
Proof. by move=> ? fD1 ?; apply: fD1. Qed.

Lemma on2S : (forall x, f x \in D2) -> {on D2 &, allQ2 f} -> allQ2 f.
Proof. by move=> ? fD1 ? ?; apply: fD1. Qed.

Lemma on1S_in : {homo f : x / x \in D1 >-> x \in D2} ->
  {in D1, {on D2, allQ1 f}} -> {in D1, allQ1 f}.
Proof. by move=> fD fD1 ? ?; apply/fD1/fD. Qed.

Lemma on1lS_in : {homo f : x / x \in D1 >-> x \in D2} ->
  {in D1, {on D2, allQ1l f & h}} -> {in D1, allQ1l f h}.
Proof. by move=> fD fD1 ? ?; apply/fD1/fD. Qed.

Lemma on2S_in : {homo f : x / x \in D1 >-> x \in D2} ->
  {in D1 &, {on D2 &, allQ2 f}} -> {in D1 &, allQ2 f}.
Proof. by move=> fD fD1 ? ? ? ?; apply: fD1 => //; apply: fD. Qed.

Lemma in_on1S : (forall x, f x \in D2) -> {in T1, {on D2, allQ1 f}} -> allQ1 f.
Proof. by move=> fD2 fD1 ?; apply: fD1. Qed.

Lemma in_on1lS : (forall x, f x \in D2) ->
  {in T1, {on D2, allQ1l f & h}} -> allQ1l f h.
Proof. by move=> fD2 fD1 ?; apply: fD1. Qed.

Lemma in_on2S : (forall x, f x \in D2) ->
  {in T1 &, {on D2 &, allQ2 f}} -> allQ2 f.
Proof. by move=> fD2 fD1 ? ?; apply: fD1. Qed.

End LocalGlobal.
Arguments in_on1P  {T1 T2 D1 D2 f Q1}.
Arguments in_on1lP {T1 T2 T3 D1 D2 f h Q1l}.
Arguments in_on2P  {T1 T2 D1 D2 f Q2}.
Arguments on1W_in  {T1 T2 D1} D2 {f Q1}.
Arguments on1lW_in {T1 T2 T3 D1} D2 {f h Q1l}.
Arguments on2W_in  {T1 T2 D1} D2 {f Q2}.
Arguments in_on1W  {T1 T2} D1 D2 {f Q1}.
Arguments in_on1lW {T1 T2 T3} D1 D2 {f h Q1l}.
Arguments in_on2W  {T1 T2} D1 D2 {f Q2}.
Arguments on1S     {T1 T2} D2 {f Q1}.
Arguments on1lS    {T1 T2 T3} D2 {f h Q1l}.
Arguments on2S     {T1 T2} D2 {f Q2}.
Arguments on1S_in  {T1 T2 D1} D2 {f Q1}.
Arguments on1lS_in {T1 T2 T3 D1} D2 {f h Q1l}.
Arguments on2S_in  {T1 T2 D1} D2 {f Q2}.
Arguments in_on1S  {T1 T2} D2 {f Q1}.
Arguments in_on1lS {T1 T2 T3} D2 {f h Q1l}.
Arguments in_on2S  {T1 T2} D2 {f Q2}.

Section in_sig.
Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0).
Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0).
Local Notation "{ 'all3' P }" := (forall x y z, P x y z : Prop) (at level 0).

Variables T1 T2 T3 : Type.
Variables (D1 : {pred T1}) (D2 : {pred T2})  (D3 : {pred T3}).
Variable P1 : T1 -> Prop.
Variable P2 : T1 -> T2 -> Prop.
Variable P3 : T1 -> T2 -> T3 -> Prop.

Lemma in1_sig : {in D1, {all1 P1}} -> forall x : sig D1, P1 (sval x).
Proof. by move=> DP [x Dx]; have := DP _ Dx. Qed.

Lemma in2_sig : {in D1 & D2, {all2 P2}} ->
  forall (x : sig D1) (y : sig D2), P2 (sval x) (sval y).
Proof. by move=> DP [x Dx] [y Dy]; have := DP _ _ Dx Dy. Qed.

Lemma in3_sig : {in D1 & D2 & D3, {all3 P3}} ->
  forall (x : sig D1) (y : sig D2) (z : sig D3), P3 (sval x) (sval y) (sval z).
Proof. by move=> DP [x Dx] [y Dy] [z Dz]; have := DP _ _ _ Dx Dy Dz. Qed.

End in_sig.
Arguments in1_sig {T1 D1 P1}.
Arguments in2_sig {T1 T2 D1 D2 P2}.
Arguments in3_sig {T1 T2 T3 D1 D2 D3 P3}.

(******************)
(* v8.15 addtions *)
(******************)

Section ReflectCombinators.

Variables (P Q : Prop) (p q : bool).

Hypothesis rP : reflect P p.
Hypothesis rQ : reflect Q q.

Lemma negPP : reflect (~ P) (~~ p).
Proof. by apply:(iffP negP); apply: contra_not => /rP. Qed.

Lemma andPP : reflect (P /\ Q) (p && q).
Proof. by apply: (iffP andP) => -[/rP ? /rQ ?]. Qed.

Lemma orPP : reflect (P \/ Q) (p || q).
Proof. by apply: (iffP orP) => -[/rP ?|/rQ ?]; tauto. Qed.

Lemma implyPP : reflect (P -> Q) (p ==> q).
Proof. by apply: (iffP implyP) => pq /rP /pq /rQ. Qed.

End ReflectCombinators.
Arguments negPP {P p}.
Arguments andPP {P Q p q}.
Arguments orPP {P Q p q}.
Arguments implyPP {P Q p q}.
Prenex Implicits negPP andPP orPP implyPP.

(*******************)
(* v8.16 additions *)
(*******************)

(******************************************************************************)
(*          pred_oapp T D := [pred x | oapp (mem D) false x]                  *)
(******************************************************************************)

Lemma mono1W_in (aT rT : predArgType) (f : aT -> rT) (aD : {pred aT})
    (aP : pred aT) (rP : pred rT) :
  {in aD, {mono f : x / aP x >-> rP x}} ->
  {in aD, {homo f : x / aP x >-> rP x}}.
Proof. by move=> fP x xD xP; rewrite fP. Qed.
Arguments mono1W_in [aT rT f aD aP rP].

#[deprecated(since="mathcomp 1.14.0", note="Use mono1W_in instead.")]
Notation mono2W_in := mono1W_in.

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

(*******************)
(* v8.17 additions *)
(*******************)

Lemma all_sig2_cond {I T} (C : pred I) P Q :
    T -> (forall x, C x -> {y : T | P x y & Q x y}) ->
  {f : I -> T | forall x, C x -> P x (f x) & forall x, C x -> Q x (f x)}.
Proof.
by move=> /all_sig_cond/[apply]-[f Pf]; exists f => i Di; have [] := Pf i Di.
Qed.

Lemma can_in_pcan [rT aT : Type] (A : {pred aT}) [f : aT -> rT] [g : rT -> aT] :
  {in A, cancel f g} -> {in A, pcancel f (fun y : rT => Some (g y))}.
Proof. by move=> fK x Ax; rewrite fK. Qed.

Lemma pcan_in_inj [rT aT : Type] [A : {pred aT}]
    [f : aT -> rT] [g : rT -> option aT] :
  {in A, pcancel f g} -> {in A &, injective f}.
Proof. by move=> fK x y Ax Ay /(congr1 g); rewrite !fK// => -[]. Qed.

Lemma in_inj_comp A B C (f : B -> A) (h : C -> B) (P : pred B) (Q : pred C) :
  {in P &, injective f} -> {in Q &, injective h} -> {homo h : x / Q x >-> P x} ->
  {in Q &, injective (f \o h)}.
Proof.
by move=> Pf Qh QP x y xQ yQ xy; apply Qh => //; apply Pf => //; apply QP.
Qed.

Lemma can_in_comp [A B C : Type] (D : {pred B}) (D' : {pred C})
    [f : B -> A] [h : C -> B] [f' : A -> B] [h' : B -> C] :
  {homo h : x / x \in D' >-> x \in D} ->
  {in D, cancel f f'} -> {in D', cancel h h'} ->
  {in D', cancel (f \o h) (h' \o f')}.
Proof. by move=> hD fK hK c cD /=; rewrite fK ?hK ?hD. Qed.

Lemma pcan_in_comp [A B C : Type] (D : {pred B}) (D' : {pred C})
    [f : B -> A] [h : C -> B] [f' : A -> option B] [h' : B -> option C] :
  {homo h : x / x \in D' >-> x \in D} ->
  {in D, pcancel f f'} -> {in D', pcancel h h'} ->
  {in D', pcancel (f \o h) (obind h' \o f')}.
Proof. by move=> hD fK hK c cD /=; rewrite fK/= ?hK ?hD. Qed.

Definition pred_oapp T (D : {pred T}) : pred (option T) :=
  [pred x | oapp (mem D) false x].

Lemma ocan_in_comp [A B C : Type] (D : {pred B}) (D' : {pred C})
    [f : B -> option A] [h : C -> option B] [f' : A -> B] [h' : B -> C] :
  {homo h : x / x \in D' >-> x \in pred_oapp D} ->
  {in D, ocancel f f'} -> {in D', ocancel h h'} ->
  {in D', ocancel (obind f \o h) (h' \o f')}.
Proof.
move=> hD fK hK c cD /=; rewrite -[RHS]hK/=; case hcE : (h c) => [b|]//=.
have bD : b \in D by have := hD _ cD; rewrite hcE inE.
by rewrite -[b in RHS]fK; case: (f b) => //=; have /hK := cD; rewrite hcE.
Qed.

Lemma eqbLR (b1 b2 : bool) : b1 = b2 -> b1 -> b2.
Proof. by move->. Qed.

Lemma eqbRL (b1 b2 : bool) : b1 = b2 -> b2 -> b1.
Proof. by move->. Qed.

Lemma homo_mono1 [aT rT : Type] [f : aT -> rT] [g : rT -> aT]
    [aP : pred aT] [rP : pred rT] :
  cancel g f ->
  {homo f : x / aP x >-> rP x} ->
  {homo g : x / rP x >-> aP x} -> {mono g : x / rP x >-> aP x}.
Proof. by move=> gK fP gP x; apply/idP/idP => [/fP|/gP//]; rewrite gK. Qed.

Lemma if_and b1 b2 T (x y : T) :
  (if b1 && b2 then x else y) = (if b1 then if b2 then x else y else y).
Proof. by case: b1 b2 => [] []. Qed.

Lemma if_or b1 b2 T (x y : T) :
  (if b1 || b2 then x else y) = (if b1 then x else if b2 then x else y).
Proof. by case: b1 b2 => [] []. Qed.

Lemma if_implyb b1 b2 T (x y : T) :
  (if b1 ==> b2 then x else y) = (if b1 then if b2 then x else y else x).
Proof. by case: b1 b2 => [] []. Qed.

Lemma if_implybC b1 b2 T (x y : T) :
  (if b1 ==> b2 then x else y) = (if b2 then x else if b1 then y else x).
Proof. by case: b1 b2 => [] []. Qed.

Lemma if_add b1 b2 T (x y : T) :
  (if b1 (+) b2 then x else y) = (if b1 then if b2 then y else x else if b2 then x else y).
Proof. by case: b1 b2 => [] []. Qed.

(********************)
(* Future additions *)
(********************)

Notation "[ 'in' A ]" := (in_mem^~ (mem A))
  (at level 0, format "[ 'in'  A ]") : fun_scope.

Notation "[ 'predI' A & B ]" := (predI [in A] [in B]) : fun_scope.
Notation "[ 'predU' A & B ]" := (predU [in A] [in B]) : fun_scope.
Notation "[ 'predD' A & B ]" := (predD [in A] [in B]) : fun_scope.
Notation "[ 'predC' A ]" := (predC [in A]) : fun_scope.
Notation "[ 'preim' f 'of' A ]" := (preim f [in A]) : fun_scope.


Require Export VST.floyd.proofauto.
Require Export VST.floyd.reassoc_seq.
Require Export aes.aes.
Require Export aes.GF_ops_LL.
Require Export aes.tablesLL.
Require Export aes.spec_utils_LL.
Require Export aes.list_utils.
Require Export aes.spec_encryption_LL.

Open Scope logic.
Local Open Scope Z.

Require Import VST.floyd.Funspec_old_Notation.
#[export] Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition t_struct_aesctx := Tstruct _mbedtls_aes_context_struct noattr.
Definition t_struct_tables := Tstruct _aes_tables_struct noattr.

Definition tables_initialized (tables : val) := data_at Ews t_struct_tables
  (map Vint FSb, (map Vint FT0, (map Vint FT1, (map Vint FT2, (map Vint FT3,
  (map Vint RSb, (map Vint RT0, (map Vint RT1, (map Vint RT2, (map Vint RT3,
  (map Vint RCON))))))))))) tables.

Definition Vundef256 : list val := repeat Vundef 256%nat.

Definition tables_uninitialized tables := data_at Ews t_struct_tables (Vundef256,
  (Vundef256, (Vundef256, (Vundef256, (Vundef256, (Vundef256,
  (Vundef256, (Vundef256, (Vundef256, (Vundef256,
  (repeat Vundef 10))))))))))) tables.

Definition gen_tables_spec :=
  DECLARE _aes_gen_tables
    WITH gv: globals
    PRE [  ]
      PROP ()
      LOCAL (gvars gv)
      SEP (tables_uninitialized (gv _tables))
    POST [ tvoid ]
      PROP ()
      LOCAL ()
      SEP (tables_initialized (gv _tables))
.

(* TODO replace this HL spec by a LL spec, and move HL spec to actual spec *)

Definition word_to_int (w : (int * int * int * int)) : int :=
  match w with (b0, b1, b2, b3) =>
    (Int.or (Int.or (Int.or
             b0
    (Int.shl b1 (Int.repr  8)))
    (Int.shl b2 (Int.repr 16)))
    (Int.shl b3 (Int.repr 24)))
  end.

(* SubWord function from section 5.2: apply S-box to each byte in a word *)
Definition SubWord (w: int) : int := word_to_int (
  (Znth (byte0 w) FSb),
  (Znth (byte1 w) FSb),
  (Znth (byte2 w) FSb),
  (Znth (byte3 w) FSb)
).

Definition RotWord(i: int): int :=
  Int.or (Int.and (Int.shl i (Int.repr 8)) (Int.repr (-1))) (Int.shru i (Int.repr 24)).

(* round constant (RCon) array, described in section 5.2 and explicitly written
 * out in appendix A.3 (256-bit key expansion example) *)
Definition RCon : list int := map (fun i => Int.shl i (Int.repr 24)) [
  (* 0x01000000 *) (Int.repr 1);
  (* 0x02000000 *) (Int.repr 2);
  (* 0x04000000 *) (Int.repr 4);
  (* 0x08000000 *) (Int.repr 8);
  (* 0x10000000 *) (Int.repr 16);
  (* 0x20000000 *) (Int.repr 32);
  (* 0x40000000 *) (Int.repr 64)
].

Definition GrowKeyByOne(w: list int): list int :=
  let i := Zlength w in
  let temp := (Znth (i-1) w) in
  let temp' := if (i mod Nk =? 0) then
    Int.xor (SubWord (RotWord temp)) (Znth (i/Nk) RCon)
  else if (i mod Nk =? 4) then
    SubWord temp
  else
    temp
  in
    w ++ [Int.xor (Znth (i-8) w) temp'].

Fixpoint pow_fun{T: Type}(f: T -> T)(n: nat)(a: T): T := match n with
| O => a
| S m => f (pow_fun f m a)
end.

(* +2 because 1 is for the initial round which is not counted, and 1 superfluous round key is
   created in the last loop iteration, because each iteration creates 2 round keys.
   -Nk because the first two round keys are just the unexpanded key.
  Note that (Nb*(Nr+2)-Nk) = 56. *)
Definition KeyExpansion2: list int -> list int := pow_fun GrowKeyByOne (Z.to_nat (Nb*(Nr+2)-Nk)).

(* arr: list of bytes *)
Definition get_uint32_le (arr: list Z) (i: Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth  i    arr))
   (Int.shl (Int.repr (Znth (i+1) arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth (i+2) arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth (i+3) arr)) (Int.repr 24))).

Definition key_bytes_to_key_words(key_bytes: list Z): list int :=
  fill_list 8 (fun i => get_uint32_le key_bytes (i*4)).

(* end TODO *)

(* Note: clightgen turns global variables of type int to pointers to int, to make them addressable,
   so aes_init_done is a pointer to int, not an int! *)
Definition key_expansion_spec :=
  DECLARE _mbedtls_aes_setkey_enc
    WITH ctx : val, key : val, ctx_sh : share, key_sh : share, key_chars : list Z,
         init_done : Z, ish: share, gv: globals
    PRE [ _ctx OF (tptr t_struct_aesctx), _key OF (tptr tuchar), _keybits OF tuint  ]
      PROP (writable_share ctx_sh; readable_share key_sh; readable_share ish;
            Zlength key_chars = 32;
            init_done = 1 (*TODO also prove case where init_done=0*))
      LOCAL (temp _ctx ctx; temp _key key; temp _keybits (Vint (Int.repr 256));
             gvars gv)
      SEP (data_at ctx_sh t_struct_aesctx
                   (Vint Int.zero,
                   (nullval,
                   (map Vint (repeat_op_table 68 Int.zero id)))) ctx;
           data_at key_sh (tarray tuchar (4*8)) (map Vint (map Int.repr key_chars)) key;
           (*if init_done ?= 1 then tables_initialized tables else tables_uninitialized tables*)
           data_at ish tint (Vint (Int.repr init_done)) (gv _aes_init_done);
           tables_initialized (gv _tables))
    POST [  tint ]
      PROP ()
      LOCAL (temp ret_temp (Vint Int.zero))
      SEP (data_at key_sh (tarray tuchar (4*8)) (map Vint (map Int.repr key_chars)) key;
           data_at ctx_sh t_struct_aesctx
                   (Vint (Int.repr 14),
                   ((field_address t_struct_aesctx [StructField _buf] ctx),
                   (map Vint (KeyExpansion2 (key_bytes_to_key_words key_chars))
                    ++ (repeat_op_table 4 (Vint Int.zero) id)))) ctx;
           data_at ish tint (Vint (Int.repr init_done)) (gv _aes_init_done);
           tables_initialized (gv _tables)).

Definition encryption_spec_ll :=
  DECLARE _mbedtls_aes_encrypt
  WITH ctx : val, input : val, output : val, (* arguments *)
       ctx_sh : share, in_sh : share, out_sh : share, (* shares *)
       plaintext : list Z, (* 16 chars *)
       exp_key : list Z, (* expanded key, 4*(Nr+1)=60 32-bit integers *)
       gv: globals (* global var *)
  PRE [ _ctx OF (tptr t_struct_aesctx), _input OF (tptr tuchar), _output OF (tptr tuchar) ]
    PROP (Zlength plaintext = 16; Zlength exp_key = 60;
          readable_share ctx_sh; readable_share in_sh; writable_share out_sh)
    LOCAL (temp _ctx ctx; temp _input input; temp _output output; gvars gv)
    SEP (data_at ctx_sh (t_struct_aesctx) (
          (Vint (Int.repr Nr)),
          ((field_address t_struct_aesctx [StructField _buf] ctx),
          (map Vint (map Int.repr (exp_key ++ (repeat 0 (8%nat))))))
          (* The following weaker precondition would also be provable, but less conveniently, and   *)
          (* since mbedtls_aes_init zeroes the whole buffer, we exploit this to simplify the proof  *)
          (* ((map Vint (map Int.repr exp_key)) ++ (repeat Vundef (8%nat)))) *)
         ) ctx;
         data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
         data_at_ out_sh (tarray tuchar 16) output;
         tables_initialized (gv _tables))
  POST [ tvoid ]
    PROP() LOCAL()
    SEP (data_at ctx_sh (t_struct_aesctx) (
          (Vint (Int.repr Nr)),
          ((field_address t_struct_aesctx [StructField _buf] ctx),
          (map Vint (map Int.repr (exp_key ++ (repeat 0 (8%nat))))))
         ) ctx;
         data_at in_sh  (tarray tuchar 16)
                 (map Vint (map Int.repr plaintext)) input;
         data_at out_sh (tarray tuchar 16)
                 (map Vint (mbed_tls_aes_enc plaintext (exp_key ++ (repeat 0 (8%nat))))) output;
         tables_initialized (gv _tables)).

Definition Gprog : funspecs := ltac:(with_library prog [
  gen_tables_spec; key_expansion_spec; encryption_spec_ll
]).

(* This is to make sure do_compute_expr (invoked by load_tac and others), which calls hnf on the
   expression it's computing, does not unfold field_address.
   TODO floyd: Ideally, we'd have "Global Opaque field_address field_address0" in the library,
   but some proofs want to unfold field_address (they shouldn't, though). *)
Global Opaque field_address.

(* entailer! calls simpl, and if simpl tries to evaluate a column of the final AES encryption result,
   it takes forever, so we have to prevent this: *)
Arguments col _ _ : simpl never.
(* Same problem with "Z.land _ 255" *)
Arguments Z.land _ _ : simpl never.

(* This one is to prevent simplification of "12 - _", which is fast, but produces silly verbose goals *)
Arguments Nat.sub _ _ : simpl never.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.verif_sha_update3.
Local Open Scope Z.
Local Open Scope logic.

Lemma Hblocks_lem:
 forall {blocks: list int} {frag: list byte} {data},
 intlist_to_bytelist blocks = frag ++ sublist 0 (Zlength blocks * 4 - Zlength frag) data ->
 Zlength frag <= Zlength blocks * 4.
Proof.
intros.
assert (Zlength (intlist_to_bytelist blocks) =
               Zlength ( frag ++
     sublist 0 (Zlength blocks * 4 - Zlength frag) data)) by congruence.
 autorewrite with sublist in H0.
 pose proof (Zlength_nonneg (sublist 0 (Zlength blocks * 4 - Zlength frag) data)).
 lia.
Qed.

Definition sha_update_loop_body :=
  (Ssequence
     (Scall None
        (Evar _sha256_block_data_order
           (Tfunction
              (Tcons (tptr t_struct_SHA256state_st) (Tcons (tptr tvoid) Tnil))
              tvoid cc_default))
        [Etempvar _c (tptr t_struct_SHA256state_st);
        Etempvar _data (tptr tuchar)])
     (Ssequence
        (Sset _data
           (Ebinop Oadd (Etempvar _data (tptr tuchar))
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) (tptr tuchar)))
        (Sset _len
           (Ebinop Osub (Etempvar _len tuint)
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) tuint)))).

Definition update_outer_if :=
     Sifthenelse
        (Ebinop Cop.One (Etempvar _n tuint) (Econst_int (Int.repr 0) tint) tint)
        (Ssequence
           (Sset _fragment
              (Ebinop Osub
                 (Ebinop Omul (Econst_int (Int.repr 16) tint)
                    (Econst_int (Int.repr 4) tint) tint) (Etempvar _n tuint)
                 tuint)) update_inner_if)
        Sskip.

Lemma update_outer_if_proof:
 forall  (Espec : OracleKind) (hashed : list int)
           (dd data : list byte) (c d : val) (wsh sh : share) (len : Z) gv
   (H : 0 <= len <= Zlength data)
   (Hwsh: writable_share wsh)
   (Hsh: readable_share sh)
   (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
   (H3 : Zlength dd < CBLOCKz)
   (H4 : (LBLOCKz | Zlength hashed))
   (Hlen : len <= Int.max_unsigned),
semax
     (func_tycontext f_SHA256_Update Vprog Gtot nil)
  (PROP  ()
   LOCAL (temp _p (field_address t_struct_SHA256state_st [StructField _data] c);
   temp _n (Vint (Int.repr (Zlength dd))); temp _data d; gvars gv; temp _c c;
   temp _data_ d; temp _len (Vint (Int.repr len)))
   (*LOCAL
   (temp _p (field_address t_struct_SHA256state_st [StructField _data] c);
    temp _n (Vint (Int.repr (Zlength dd)));
    temp _data d; temp _c c;temp _data_ d;
    temp _len (Vint (Int.repr len));
    gvars gv)*)
   SEP  (data_at wsh t_struct_SHA256state_st
                 (map Vint (hash_blocks init_registers hashed),
                  (Vint (lo_part (bitlength hashed dd + len*8)),
                   (Vint (hi_part (bitlength hashed dd + len*8)),
                    (map Vubyte dd ++ repeat Vundef (Z.to_nat (CBLOCKz-Zlength dd)),
                     Vint (Int.repr (Zlength dd))))))
               c;
     K_vector gv;
     data_block sh data d))
  update_outer_if
  (overridePost (sha_update_inv wsh sh hashed len c d dd data gv false)
    (frame_ret_assert
     (function_body_ret_assert tvoid
        (EX  a' : s256abs,
         PROP  (update_abs (sublist 0 len data) (S256abs hashed dd) a')
         LOCAL ()
         SEP  (K_vector gv;
                 sha256state_ wsh a' c; data_block sh data d)))
    emp)).
Proof.
intros.
unfold update_outer_if.
forward_if (sha_update_inv wsh sh hashed len c d dd data gv false).
* (* then clause *)

Time forward.  (* fragment = SHA_CBLOCK-n; *) (*2.2*)
(*drop_LOCAL 5%nat.*)
rewrite semax_seq_skip.
fold (inv_at_inner_if wsh sh hashed len c d dd data gv).
apply semax_seq with (sha_update_inv wsh sh hashed len c d dd data gv false).
weak_normalize_postcondition.
normalize. change (16*4)%Z with 64.
simple apply (update_inner_if_proof Espec hashed dd data c d wsh sh len gv);
  try assumption.
forward.
apply andp_left2; auto.
* (* else clause *)
forward.  (* skip; *)
Exists (@nil int). rewrite <- app_nil_end.
rename H0 into H1.
rewrite H1 in *.
rewrite Zlength_correct in H1;  destruct dd; inv H1.
autorewrite with sublist.
simpl intlist_to_bytelist.
Time entailer!.  (* 4.6; was: 139 sec -> 3.27 sec *)
split.
apply Z.divide_0_r.
rewrite field_address0_offset by auto with field_compatible.
simpl. normalize.

(* TODO:  see if a "stronger" proof system could work here
  rewrite data_at_field_at.
   apply field_at_stronger.
  ...
  with automatic cancel...
*)

Tactic Notation "unfold_data_atx" uconstr(a) :=
 tryif (is_nat_uconstr a)
 then (
    idtac "Warning: unfold_data_at with numeric argument is deprecated";
     let x := constr:(a) in unfold_data_at_tac x
   )
 else
 (let x := fresh "x" in set (x := a : mpred);
  lazymatch goal with
  | x := ?D : mpred |- _ =>
    match D with
     | (@data_at_ ?cs ?sh ?t ?p) =>
            change D with (@field_at_mark cs sh t (@nil gfield) (@default_val cs (@nested_field_type cs t nil)) p) in x
     | (@data_at ?cs ?sh ?t ?v ?p) =>
            change D with (@field_at_mark cs sh t (@nil gfield) v p) in x
     | (@field_at_ ?cs ?sh ?t ?gfs ?p) =>
            change D with (@field_at_mark cs sh t gfs (@default_val cs (@nested_field_type cs t gfs)) p) in x
     | (@field_at ?cs ?sh ?t ?gfs ?v ?p) =>
            change D with (@field_at_mark cs sh t gfs v p) in x
     end;
        subst x;  unfold_field_at';
idtac (*
   repeat match goal with |- context [@field_at ?cs ?sh ?t ?gfs (@default_val ?cs' ?t') ?p] =>
       change (@field_at cs sh t gfs (default_val cs' t') p) with (@field_at_ cs sh t gfs p)
    end*)
end).
 match goal with |- ?A |-- ?B => unfold_data_at A; unfold_data_at B; cancel end.
Time Qed. (*5.4*)

Lemma update_while_proof:
 forall (Espec : OracleKind) (hashed : list int) (dd data: list byte) gv
    (c d : val) (wsh sh : share) (len : Z)
  (H : 0 <= len <= Zlength data)
   (Hwsh: writable_share wsh)
   (Hsh: readable_share sh)
  (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
  (H3 : Zlength dd < CBLOCKz)
  (H4 : (LBLOCKz | Zlength hashed))
  (Hlen : len <= Int.max_unsigned),
 semax
       (func_tycontext f_SHA256_Update Vprog Gtot nil)
  (sha_update_inv wsh sh hashed len c d dd data gv false)
  (Swhile
     (Ebinop Oge (Etempvar _len tuint)
        (Ebinop Omul (Econst_int (Int.repr 16) tint)
           (Econst_int (Int.repr 4) tint) tint) tint) sha_update_loop_body)
  (normal_ret_assert (sha_update_inv wsh sh hashed len c d dd data gv true)).
Proof.
intros.
abbreviate_semax.
unfold sha_update_inv.
Intros blocks.
rewrite semax_seq_skip. (* should be part of forward_while *)
forward_while
    (sha_update_inv wsh sh hashed len c d dd data gv false);
  try rename blocks0 into blocks'.
*
 Exists blocks. entailer!.
*
  entailer!.
*
 clear H8.
 normalize_postcondition.
 clear dependent blocks.
 rename blocks' into blocks.
 pose proof (Hblocks_lem H7).
 assert (H0': (Zlength dd <= Zlength blocks * 4)%Z) by Omega1.
 clear H0; rename H0' into H0.
 rewrite Int.unsigned_repr in HRE by lia.
 pose (bl := bytelist_to_intlist (sublist (Zlength blocks * 4 - Zlength dd)
                                                   (Zlength blocks * 4 - Zlength dd + CBLOCKz) data)).
assert (Zlength bl = LBLOCKz). {
 apply Zlength_bytelist_to_intlist.
 pose proof CBLOCKz_eq; pose proof LBLOCKz_eq;
  autorewrite with sublist. reflexivity.
}
 {
  rename H6 into Hdiv. rename H7 into Hblocks. rename H0 into H7.
  rename HRE into Hlen_ge.  clear H5.
  assert (H6: sublist (Zlength blocks * 4 - Zlength dd)
                    (Zlength blocks * 4 - Zlength dd + CBLOCKz) data =
        intlist_to_bytelist bl).
  unfold bl; rewrite bytelist_to_intlist_to_bytelist; auto.
  pose proof CBLOCKz_eq;  autorewrite with sublist.
  exists LBLOCKz; reflexivity.
  rename dd into frag.
  clear H7; rename H1 into H7.
  rename HBOUND into LEN64.
  clear - Hwsh Hsh H Hdiv H4 Hblocks H3 Hlen Hlen_ge H6 H7 LEN64.
  unfold sha_update_loop_body.
  assert (Hblocks' := Hblocks_lem Hblocks).
  Time assert_PROP (field_compatible (tarray tuchar (Zlength data)) [] d) as FC by entailer!. (*1.8*)
  assert (DM: Zlength data < Ptrofs.modulus).
  { (* TODO: simplify this proof. *)
    clear - FC. red in FC. simpl in FC. destruct d; try tauto.
    simpl in FC.
    rewrite Z.max_r in FC by (specialize (Zlength_nonneg data); intros; lia).
    inv_int i.
    rewrite Z.mul_1_l in FC.
    lia.
  }
  set (lo := Zlength blocks * 4 - Zlength frag) in *.
  replace_SEP 2
    (data_block sh (sublist 0 lo data) d *
       data_block sh (sublist lo (lo+CBLOCKz) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc lo] d) *
       data_block sh (sublist (lo+CBLOCKz) (Zlength data) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc (lo+CBLOCKz)] d)).
  { Time entailer!. (*2.5*)
   rewrite (split3_data_block lo (lo+CBLOCKz) sh data); auto;
     subst lo; Omega1.
  }
 rewrite H6.
 assert (LBLOCKz | Zlength (hashed ++ blocks))
  by (apply divide_length_app; auto).
 assert (Zlength (hash_blocks init_registers (hashed ++ blocks)) = 8)
  by (rewrite Zlength_length; [apply length_hash_blocks|]; auto).
 Time forward_call (* sha256_block_data_order (c,data); *)
   (hash_blocks init_registers (hashed++blocks),  bl, c, wsh,
    field_address0 (tarray tuchar (Zlength data))  [ArraySubsc lo] d,
    sh, gv). (*3.8*)
  { Time unfold_data_at (data_at _ _ _ c). (*0.8*)
    Time cancel. (*2.5*)
  }
 rewrite hash_blocks_last by auto.
 Time forward. (* data += SHA_CBLOCK; *) (*5*)
 simpl (temp _data _).
 Time forward. (* len  -= SHA_CBLOCK; *) (*6*)
 Exists (blocks++ bl).
 Time entailer!. (*17.4 SLOW*)
 subst lo. autorewrite with sublist.
 rewrite Z.mul_add_distr_r.
 {repeat split; auto.
  + Omega1.
  + rewrite H7; apply Z.divide_add_r; auto. apply Z.divide_refl.
  + rewrite intlist_to_bytelist_app.
      rewrite Hblocks; rewrite <- H6.
      rewrite app_ass.
      f_equal.
      rewrite <- sublist_split; try Omega1.
      f_equal. Omega1.
  + assert (0 <= Zlength blocks * 4 + Zlength bl * 4 - Zlength frag <= Zlength data)
         by Omega1.
      rewrite !field_address0_offset by auto with field_compatible.
      rewrite offset_offset_val.
      simpl. f_equal. Omega1.
  + f_equal. f_equal. Omega1.
 }
 Time unfold_data_at (data_at _ _ _ c).  (*0.8*)
 rewrite (split3_data_block lo (lo+CBLOCKz) sh data d)
    by (auto; subst lo; try Omega1).
 rewrite app_ass.
 rewrite H6.
 Time cancel. (*1.2*)
 }
*
 assert  (Zlength blocks' * 4 >= Zlength dd).
   rewrite <- (Zlength_intlist_to_bytelist blocks').
   rewrite H7. autorewrite with sublist. Omega1.
 normalize in HRE.
 unfold sha_update_inv.
 clear dependent blocks.
 forward.
 Exists blocks'.
 Time entailer!. (*2.9*)
Time Qed. (*VST2.0: 1.7s *)


(** * ADT: Abstract Data Types *)

(** An _abstract data type_ (ADT) can be defined as a set of values
    together with some operations.  From the perspective of formal
    verification, the specifications of those operations should also
    be a part of an ADT.

    When we implemented BSTs in [SearchTree], we saw that
    maintaining a representation invariant was important to rule out
    trees that could never be constructed through operations of the
    data structure.  That invariant became a precondition for many
    operations, though there was no need for _clients_ of the data
    structure to know any details of the invariant.

    In this chapter we'll study a little of Coq's _module system_,
    which enables hiding some details of the implementation of an ADT,
    while also exposing the formal specification of the ADT.

    Some prior knowledge of an ML-style module system, especially
    OCaml's, will be helpful.  Here are some sources that cover it:

    - _Introduction to Objective Caml_, chapters 12 and 13.  Jason
      Hickey, 2008.  Available from
      {https://ocaml.org/learn/books.html}.

    - The OCaml System Manual, chapter 2.  Xavier Leroy et al.,
      2020. Available from
      {http://caml.inria.fr/pub/docs/manual-ocaml/}.  *)

From Coq Require Import String.  (* for manual grading *)
From VFA Require Import Perm.
From VFA Require Import Maps.
From VFA Require Import SearchTree.

(* ################################################################# *)
(** * The Table ADT *)

(** An _association table_ is an ADT that binds keys to values.  There
    are many other names for this concept, including _map_.  We've
    already used that name before, though, for a specific data
    structure using higher-order functions.  So for clarity in this
    chapter we use _table_.

    Below is a Coq [Module Type] that declares an _interface_ for the
    table ADT. A _parameter_ is like a definition, except it declares
    only the type of an identifier, not the value to which it is
    bound.  An _axiom_ is similarly like a theorem, except no proof is
    provided. *)

Module Type Table.

  (** A [table] is a binding from keys to values. It is _total_,
      meaning it binds all keys. *)
  Parameter table : Type.

  (** Keys are natural numbers. *)
  Definition key := nat.

  (** Values are an arbitrary type [V]. *)
  Parameter V : Type.

  (** The default value to which keys are bound. *)
  Parameter default : V.

  (** [empty] is the table that binds all keys to the default value. *)
  Parameter empty : table.

  (** [get k t] is the value [v] to which [k] is bound in [t]. *)
  Parameter get : key -> table -> V.

  (** [set k v t] is the table that binds [k] to [v] and otherwise has
      the same bindings as [t]. *)
  Parameter set : key -> V -> table -> table.

  (** The following three axioms are an equational specification for
      the table ADT. *)

  Axiom get_empty_default : forall (k : key),
      get k empty = default.

  Axiom get_set_same : forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.

  Axiom get_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.

End Table.

(* ################################################################# *)
(** * Implementing [Table] with Functions *)

(** We can _implement_ [Table] with a [Module] that is
    parameterized on the type of values -- or, rather, parameterized
    on a module that contains such a type.  A parameterized module is
    also called a _functor_.

    Module type [ValType] says that there must be a type named [V],
    with a default value provided: *)

Module Type ValType.
  Parameter V : Type.
  Parameter default : V.
End ValType.

(** Functor [FunTable] takes as input a module of type
    [ValType], which must therefore contain a type [V].  As output,
    [FunTable] produces a module of type [Table].  By writing [<:
    Table], below, we ask Coq to check that the output module contains
    all the components required by [Table]. *)

Module FunTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.

  (** A [table] is a function from keys to values. *)
  Definition table := key -> V.

  Definition empty : table :=
    fun _ => default.

  Definition get (k : key) (t : table) : V :=
    t k.

  Definition set (k : key) (v : V) (t : table) : table :=
    fun k' => if k =? k' then v else t k'.

  (** The implementation must prove the theorems that the interface
      specified as axioms. *)

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof. intros. unfold get, empty. reflexivity. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof. intros. unfold get, set. bdall. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof. intros. unfold get, set. bdall. Qed.
End FunTable.

(** As an example, let's instantiate [FunTable] with strings as
    values. *)

Module StringVal.
  Definition V := string.
  Definition default := ""%string.
End StringVal.

Module FunTableExamples.

  Module StringFunTable := FunTable StringVal.
  Import StringFunTable.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof. reflexivity. Qed.

  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof. reflexivity. Qed.

  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof. reflexivity. Qed.

End FunTableExamples.

(** **** Exercise: 2 stars, standard, optional (NatFunTableExamples) *)

(** Define a module that uses [FunTable] to implement a table mapping
    keys to values, where the values have type [nat], with a default of [0].
    Write unit tests to check the operation of [get] and [set]. *)

Module NatFunTableExamples.
  (* FILL IN HERE *)
End NatFunTableExamples.

(** [] *)

(* ################################################################# *)
(** * Implementing [Table] with Lists *)

(** **** Exercise: 3 stars, standard (lists_table) *)

(** Use association lists to implement [Table]. *)

Module ListsTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := list (key * V).

  Definition empty : table := [].

  Fixpoint get (k : key) (t : table) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition set (k : key) (v : V) (t : table) : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    (* FILL IN HERE *) Admitted.

End ListsTable.

(** Instantiate your table and prove the following facts. *)

Module StringListsTableExamples.

  Module StringListsTable := ListsTable StringVal.
  Import StringListsTable.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof.
    (* FILL IN HERE *) Admitted.

  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof.
    (* FILL IN HERE *) Admitted.

  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof.
    (* FILL IN HERE *) Admitted.

End StringListsTableExamples.

(** [] *)

(* ################################################################# *)
(** * Implementing [Table] with BSTs *)

(** Tables implemented with functions and association lists are, of course,
    inefficient.  For a more efficient implementation, we can use BSTs. *)

Module TreeTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := tree V.

  Definition empty : table :=
    @empty_tree V.

  Definition get (k : key) (t: table) : V :=
    lookup default k t.

  Definition set (k : key) (v : V) (t : table) : table :=
    insert k v t.

  (** The three basic equations we proved about [tree] in
      [SearchTree] make short work of the theorems we need to
      prove for [Table]. *)

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty.
  Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set. apply lookup_insert_eq.
  Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set. apply lookup_insert_neq. assumption.
  Qed.

End TreeTable.

(* ################################################################# *)
(** * Tables with an [elements] Operation *)

(** Now let's consider a richer interface [ETable] for Tables that support
    [bound] and [elements] operation. *)

(* ================================================================= *)
(** ** A First Attempt at [ETable] *)

Module Type ETable_first_attempt.

  (** [Include], as the name suggests, includes all the declarations
      from [Table].  Not only does that save keystrokes, it also means
      if we ever update [Table] to have new operations or new types,
      they automatically get included here, too. *)
  Include Table.

  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETable_first_attempt.

(** We proved in [SearchTree] that the BST [elements] operation is
    correct and complete.  So we ought to be able to implement
    [ETable] with BSTs.  Let's try. *)

Module TreeETable_first_attempt (VT : ValType) <: ETable_first_attempt.

  (** Include all the definitions from [TreeTable], instantiated on
      [VT]. *)
  Include TreeTable VT.

  (** Thanks to the [Include], we now have all the tree operations
      defined "for free" in this module.  For example: *)
  Check get : key -> table -> V.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup. unfold get in Hlookup.
    (** [pose proof t as H] is equivalent to [assert (H : ...the type
        of t...). { apply t. }] but saves some keystrokes. *)
    pose proof (SearchTree.elements_complete) as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete with default.
    - (** Stuck! We don't know that [t] satisfies the BST invariant. *)
  Admitted.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t Hin.
    pose proof (SearchTree.elements_correct) as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect.
    - (** Again stuck because of the BST invariant. *)
  Admitted.

End TreeETable_first_attempt.

(* ================================================================= *)
(** ** A Revised [ETable] *)

(** To prove that [elements] is correct, we need to know that
    trees satisfy the BST invariant. So, we declare a function
    [rep_ok] in the interface, and use it as a precondition for values
    of type [table]. We also add axioms to state that the ADT
    operations produce values that satisfy the representation
    invariant, i.e., it is a postcondition. And, we add a
    specification of [bound]. *)

Module Type ETable.

  Include Table.

  Parameter rep_ok : table -> Prop.
  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  (** [empty] and [set] produce valid representations. *)

  Axiom empty_ok : rep_ok empty.

  Axiom set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).

  (** The specification of [bound]: *)

  Axiom bound_empty : forall (k : key),
      bound k empty = false.

  Axiom bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.

  Axiom bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.

  (** The specification of [elements]: *)

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETable.

Module TreeETable (VT : ValType) <: ETable.

  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETable.

(** Now we can use the table. *)

Module StringTreeETableExample.

  Module StringTreeETable := TreeETable StringVal.
  Import StringTreeETable.
  Open Scope string_scope.

  Example ex1 :
    In (0, "A") (elements (set 0 "A" (set 1 "B" empty))).
  Proof.
    apply elements_complete;
      auto using empty_ok, set_ok, bound_set_same, get_set_same.
  Qed.

End StringTreeETableExample.

(* ################################################################# *)
(** * Encapsulation with the Coq Module System (Advanced) *)

(** Functor [TreeETable], above, reveals internal implementation
    details that your data structures class probably taught you are
    better kept private.  For example, the constructors [E] and [T] of
    trees and the implementation of [get] are publicly exposed: *)

Example exposed_trees_ex :
  (StringTreeETableExample.StringTreeETable.get 0 (T E 0 "A" E) = "A")%string.
Proof.
  unfold StringTreeETableExample.StringTreeETable.get. (* we can see [lookup] *)
  reflexivity.
Qed.

(** Like many languages, Coq makes it possible to _encapsulate_
    these details, meaning that they become hidden outside the module.
    It's a simple matter of changing the [<:] syntax to [:] in the
    functor's type.  The only change in the implementation below is
    that one character. *)

(** The [:] syntax makes the module type _opaque_: only what is
    revealed in the type is available for code outside the module to
    use.  The [<:] syntax, however, makes the module type
    _transparent_: the module must conform to the type, but everything
    about the module is still revealed. *)

Module TreeETableFullyEncapsulated (VT : ValType) : ETable.
  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETableFullyEncapsulated.

(** Unfortunately, the module is now too encapsulated to be useful: *)

Module OverlyEncapsulatedExample.

  Module StringTreeETableFullyEncapsulated := TreeETableFullyEncapsulated StringVal.
  Import StringTreeETableFullyEncapsulated.
  Open Scope string_scope.

  Fail Example ex1 : get 0 empty = "".
  (* fails with an error about [""] not having type [V] *)

End OverlyEncapsulatedExample.

(** The problem is that the module now hides not only the internal
    implementation, but also the value type [V]. The functor was
    instantiated on [StringVal], which defines that type as [string].
    But the output of the functor has type [ETable], which doesn't
    reveal anything about [V] except that it is a [Type]. Note in the
    output of the following command how [V] is printed like an axiom
    would be, indicating that nothing is known (externally) about its
    implementation: *)

Print OverlyEncapsulatedExample.StringTreeETableFullyEncapsulated.V.

(** We need to selectively expose certain implementation details.
    We've just seen that [V] should be exposed.  Along with it, we'll
    also want [default] to be exposed.  We can accomplish that with an
    advanced feature of Coq's module system.  The Coq manual doesn't
    give this feature a name, but OCaml (in which Coq is implemented)
    calls it a _sharing constraint_, so we'll use that term here. A
    sharing constraint enables us to constrain definitions shared by
    modules to be the same. *)

Module Type SimpleTable.
  Parameter key : Type.
  Parameter V : Type.
  Parameter default : V.
  Parameter table : Type.
  (* We omit everything else for sake of a simple example. *)
End SimpleTable.

Module SimpleStringTable1 : SimpleTable.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable1.

(* [V] is abstract. *)
Print SimpleStringTable1.V.

Module Type SimpleTable2 := SimpleTable with Definition V := string.

Module SimpleStringTable2 : SimpleTable2.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable2.

(* [V] is exposed, but [default] is abstract. *)
Print SimpleStringTable2.V.
Print SimpleStringTable2.default.

Module Type SimpleTable3 := SimpleTable
  with Definition V := string
  with Definition default := ""%string.

Module SimpleStringTable3 : SimpleTable3.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable3.

(* Both [V] and [default] are exposed. *)
Print SimpleStringTable3.V.
Print SimpleStringTable3.default.

(** Putting sharing constraints to use, let's expose [V] and [default]
    in our implementation of tree-based tables. *)

Module TreeETableEncapsulated (VT : ValType) : (ETable with Definition V := VT.V with Definition default := VT.default).

  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETableEncapsulated.

Module NicelyEncapsulatedExample.

  Module StringTreeETableEncapsulated := TreeETableEncapsulated StringVal.
  Import StringTreeETableEncapsulated.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof.
    (* We can't directly simplify, because [get] is encapsulated. *)
    Fail reflexivity.
    (* But we can use the specifications exposed in the interface. *)
    apply get_empty_default.
  Qed.

  (* We can't fabricate trees with [T] and [E] anymore, because [tree]
     is encapsulated. *)
  Fail Example ex2 : get 0 (T E 0 "A" E) = "A".
End NicelyEncapsulatedExample.

(** Note what we've happily achieved: we can reason about the behavior
    of an ADT entirely from its specification, rather than depending
    on the implementation code.  This is what specification comments
    in interfaces attempt to achieve in real-world code. *)

(** **** Exercise: 4 stars, advanced, optional (elements_spec) *)

(** Develop a nicely-encapsulated interface and implementation of
    tree-based tables that exposes the rest of the specification of
    [elements] from [SearchTree], including the inverses of
    correctness and completenesss, sortedness, and
    non-duplication. Send us your solution, so we can include it! *)

(** [] *)

(* ################################################################# *)
(** * Model-based Specification *)

(** The interfaces above have been based on equational specification
    of tables.  Let's consider model-based specifications.  Recall
    from [SearchTree] that in this style of specification, we

    - introduce an abstraction function (or relation) that associates
      a _concrete value_ of the ADT implementation with an _abstract
      value_ in an already well-understood type; and

    - show that the concrete and abstract operations are related in a
      sensible way. *)

(** We begin by defining a new map operation, [bound], and redefining
    existing operations to make them more clear in the table
    specification we are about to write. *)

Definition map_update {V : Type}
           (k : key) (v : V) (m : partial_map V) : partial_map V :=
  update m k v.

Definition map_find {V : Type} := @find V.

Definition empty_map {V : Type} := @Maps.empty V.

(** Now we can define an interface for tables that includes an
    abstraction function [Abs], and specifications written in terms of
    it. *)

Module Type ETableAbs.

  Parameter table : Type.
  Definition key := nat.
  Parameter V : Type.
  Parameter default : V.

  Parameter empty : table.
  Parameter get : key -> table -> V.
  Parameter set : key -> V -> table -> table.
  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Parameter Abs : table -> partial_map V.
  Parameter rep_ok : table -> Prop.

  Axiom empty_ok :
      rep_ok empty.

  Axiom set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).

  Axiom empty_relate :
      Abs empty = empty_map.

  Axiom bound_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_bound k (Abs t) = bound k t.

  Axiom lookup_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_find default k (Abs t) = get k t.

  Axiom insert_relate : forall (t : table) (k : key) (v : V),
      rep_ok t ->
      map_update k v (Abs t) = Abs (set k v t).

  Axiom elements_relate : forall (t : table),
      rep_ok t ->
      Abs t = map_of_list (elements t).

End ETableAbs.

(** **** Exercise: 4 stars, standard (list_etable_abs) *)

(** Implement [ETableAbs] using association lists as the
    representation type. *)

Module ListETableAbs (VT : ValType) <: ETableAbs.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := list (key * V).

  Definition empty : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Fixpoint get (k : key) (t : table) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition set (k : key) (v : V) (t : table) : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Fixpoint bound (k : key) (t : table) : bool
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition elements (t : table) : list (key * V)
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition Abs (t : table) : partial_map V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition rep_ok (t : table) : Prop
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem empty_ok : rep_ok empty.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem empty_relate :
    Abs empty = empty_map.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem bound_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_bound k (Abs t) = bound k t.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem lookup_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_find default k (Abs t) = get k t.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem insert_relate : forall (t : table) (k : key) (v : V),
      rep_ok t ->
      map_update k v (Abs t) = Abs (set k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem elements_relate : forall (t : table),
      rep_ok t ->
      Abs t = map_of_list (elements t).
  Proof.
    (* FILL IN HERE *) Admitted.

End ListETableAbs.

(* Instantiate functor for sake of autograding. *)
Module StringListETableAbs := ListETableAbs StringVal.

(** [] *)

(** **** Exercise: 3 stars, standard, optional (TreeTableModel)

    Give an implementation of [ETableAbs] using the abstraction
    function [Abs] from [SearchTree]. All the proofs of the
    [relate] axioms should be simple applications of the lemmas
    already proved as exercises in that chapter. *)

(* Do not modify the following line: *)
Definition manual_grade_for_TreeTableModel : option (nat*string) := None.

(** [] *)

(** **** Exercise: 2 stars, advanced, optional (TreeTableModel') *)

(** Repeat the previous exercise, this time using the alternative
    [Abs'] function from [SearchTree]. Hint: Just tweak your
    solution to the previous exercise. *)

(** [] *)

(* ################################################################# *)
(** * Summary of ADT Verification *)

(** With equational specifications:

    - Define a _representation invariant_ to characterize which
      values of the _representation type_ are legal.  Prove that each
      operation on the representation type _preserves_ the representation
      invariant.

    - Using the representation invariant, verify the equational
      specification.

    With model-based specifications:

    - Define and verify preservation of the the representation invariant.

    - Define an _abstraction function_ that relates the
      representation type to another type that is easier to reason
      about.

    - Prove that operations of the abstract and concrete types commute
      with the abstraction function. *)

(* ################################################################# *)
(** * Another ADT: Queue *)

(** Here is an interface and algebraic specification for FIFO queues. To
    ensure totality, [peek] takes a default value and [deq] returns the
    empty queue when applied to the empty queue. *)

Module Type Queue.
  Parameter V : Type.
  Parameter queue : Type.
  Parameter empty: queue.
  Parameter is_empty : queue -> bool.
  Parameter enq : queue -> V -> queue.
  Parameter deq : queue -> queue.
  Parameter peek : V -> queue -> V.
  Axiom is_empty_empty : is_empty empty = true.
  Axiom is_empty_nonempty : forall q v, is_empty (enq q v) = false.
  Axiom peek_empty : forall d, peek d empty = d.
  Axiom peek_nonempty : forall d q v, peek d (enq q v) = peek v q.
  Axiom deq_empty : deq empty = empty.
  Axiom deq_nonempty : forall q v, deq (enq q v) = if is_empty q then q else enq (deq q) v.
End Queue.

(** **** Exercise: 3 stars, standard (list_queue) *)

(** Implement that interface and verify your implementation.  As the
    representation type, use [list V].  At least one operation will
    have to be linear time; we recommend that it be [enq]. All the
    proofs should be quite easy. *)

Module ListQueue <: Queue.
  Definition V := nat. (* for simplicity *)
  Definition queue := list V.

  Definition empty : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition is_empty (q : queue) : bool
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition enq (q : queue) (v : V) : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition deq (q : queue) : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition peek (default : V) (q : queue) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem is_empty_empty : is_empty empty = true.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem is_empty_nonempty : forall q v,
      is_empty (enq q v) = false.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_empty : forall d,
      peek d empty = d.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_nonempty : forall d q v,
      peek d (enq q v) = peek v q.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_empty :
    deq empty = empty.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_nonempty : forall q v,
      deq (enq q v) = if is_empty q then q else enq (deq q) v.
  Proof.
    (* FILL IN HERE *) Admitted.

End ListQueue.

(** [] *)

(** Here is an interface and model-based specification for queues. We omit
    [rep_ok] from it, because our intended implementation isn't going
    to require a representation invariant. *)

Module Type QueueAbs.
  Parameter V : Type.
  Parameter queue : Type.
  Parameter empty : queue.
  Parameter is_empty : queue -> bool.
  Parameter enq : queue -> V -> queue.
  Parameter deq : queue -> queue.
  Parameter peek : V -> queue -> V.
  Parameter Abs : queue -> list V.
  Axiom empty_relate : Abs empty = [].
  Axiom enq_relate : forall q v,  Abs (enq q v) = (Abs q) ++ [v].
  Axiom peek_relate : forall d q, peek d q = hd d (Abs q).
  Axiom deq_relate : forall q, Abs (deq q) = tl (Abs q).
End QueueAbs.

(** **** Exercise: 3 stars, standard (two_list_queue) *)

(** Below is an implementation of [QueueAbs] using two lists.  It
    achieves amortized constant-time performance, improving on the
    single-list implementation. Verify this implementation. *)

Module TwoListQueueAbs <: QueueAbs.
  Definition V := nat. (* for simplicity *)

  Definition queue : Type := list V * list V.

  (* [(f, b)] represents a queue with a front list [f] and a back list
     [b], where the back list is stored in reverse order. *)
  Definition Abs '((f, b) : queue) : list V :=
    f ++ (rev b).

  Definition empty : queue :=
    ([], []).

  Definition is_empty (q: queue) :=
    match q with
    | ([], []) => true
    | _ => false
    end.

  Definition enq '((f, b) : queue) (v : V) :=
    (f, v :: b).

  Definition deq (q : queue) :=
    match q with
    | ([], []) => ([], [])
    | ([], b) =>
      match rev b with
      | [] => ([], [])
      | _ :: f => (f, [])
      end
    | (_ :: f, b) => (f, b)
    end.

  Definition peek (d : V) (q : queue) :=
    match q with
    | ([], []) => d
    | ([], b) =>
      match rev b with
      | [] => d
      | v :: _ => v
      end
    | (v :: _, _) => v
    end.

  Theorem empty_relate : Abs empty = [].
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem enq_relate : forall q v,
      Abs (enq q v) = (Abs q) ++ [v].
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_relate : forall d q,
      peek d q = hd d (Abs q).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_relate : forall q,
      Abs (deq q) = tl (Abs q).
  Proof.
    (* FILL IN HERE *) Admitted.

End TwoListQueueAbs.

(** [] *)

(* ################################################################# *)
(** * Representation Invariants and Subset Types *)

(** In specifications thus far, whenever there was a representation
    invariant that needed to be enforced we had to add it as a
    precondition and postcondition for operations.  For example, the
    correctness of the table [get] operation depended on its [table]
    input satisfying [rep_ok].  We had to write propositions like [forall
    (t : table), rep_ok t -> ...], in which we had a type [table] with
    lots of values, and we got rid of some of those values by
    requiring [rep_ok] to hold of them. *)

(** Coq makes it possible to directly express the requirement that
    values of a type must satisfy a proposition.  The type

      {x : A | P}

    is the type of all values [x] of type [A] that satisfy property
    [P], which itself has type [A -> Prop].  The notation is deliberately
    suggestive of set-builder notation used in mathematics. Such types
    are known as _subset types_. *)

(* ================================================================= *)
(** ** Example: The Even Naturals *)

(** We can define the subset type of even natural numbers using
    the property [Nat.Even] from the standard library: *)

Definition even_nat := {x : nat | Nat.Even x}.

(** But when we try to say that [2] is an [even_nat], Coq rejects the
    definition: *)

Fail Definition two : even_nat := 2.

(** The problem is that [2] is a [nat], but we haven't proved [Nat.Even 2].
    The proof is easy: *)

Lemma Even2 : Nat.Even 2.
Proof. exists 1. reflexivity. Qed.

(** Now we can provide that proof to convince Coq [two] is an [even_nat].
    We can do that with function [exist], which is suggestive of
    "there exists an [x : A] such that [P x]." *)

Check exist : forall {A : Type} (P : A -> Prop) (x : A), P x -> {x : A | P x}.

Definition two : even_nat := exist Nat.Even 2 Even2.

(** Another way of constructing [two] is to enter Coq's proof scripting
    mode and use tactics.  We saw this briefly in [ProofObjects]. *)

Definition two' : even_nat.
Proof.
  apply exist with (x := 2).
  exists 1. reflexivity.
Defined.

(** That technique is often useful with subset types, because it
    helps us more easily build the proof objects, rather than have to
    write them ourselves. *)

(** A value of type [even_nat] is like a "package" containing the [nat]
    and the proof that the [nat] is even.  We have to use functions to
    extract those components from the package. *)

Fail Example plus_two : 1 + two = 3.

Check proj1_sig : forall {A : Type} {P : A -> Prop} (e : {x : A | P x}), A.

Example plus_two : 1 + proj1_sig two = 3.
Proof. reflexivity. Qed.

Check proj2_sig : forall {A : Type} {P : A -> Prop} (e : {x : A | P x}), P (proj1_sig e).

Example Even2' : Nat.Even 2 := proj2_sig two.

(* ================================================================= *)
(** ** Defining Subset Types *)

(** Like nearly everything else we've seen in Coq's logic, subset
    types are actually defined in the standard library rather than
    being built-in to the language. *)

Module SigSandbox.

  (** Subset types are just a syntactic notation for [sig]: *)

  Inductive sig {A : Type} (P : A -> Prop) : Type :=
  | exist (x : A) : P x -> sig P.

  Notation "{ x : A | P }" := (sig A (fun x => P)).

  (** The name [sig] is short for the Greek capital letter sigma,
      because subset types are similar to something known in type
      theory as _sigma types_, aka _dependent sums_. *)

  (** Subset types and existential quantification are quite similar.
      Recall how the latter is defined: *)

  Inductive ex {A : Type} (P : A -> Prop) : Prop :=
  | ex_intro (x : A) : P x -> ex P.

  (** The only difference is that [sig] creates a [Type] whereas [ex]
      creates a [Prop].  That is, the former is computational in content,
      whereas the latter is logical.  Therefore we can pattern match
      to recover the witness from a [sig], but we cannot do the same
      with an [ex]. *)

  Definition proj1_sig {A : Type} {P : A -> Prop} (e : sig P) : A :=
    match e with
    | exist _ x _ => x
    end.

  Definition proj2_sig {A : Type} {P : A -> Prop} (e : sig P) : P (proj1_sig e) :=
    match e with
    | exist _ _ p => p
    end.

  Fail Definition proj1_ex {A : Type} {P : A -> Prop} (e : ex P) : A :=
    match e with
    | ex_intro _ x _ => x
    end.

End SigSandbox.

(* ================================================================= *)
(** ** Example: Vectors *)

(** A _vector_ is a list of a known length. Type [vector X] contains
    values [(xs, n)] with a particular representation invariant: [n]
    must be the length of [xs].  *)

Definition vector (X : Type) :=
  { '(xs, n) : list X * nat | length xs = n }.

(** The type itself enforces the representation invariant, because a
    value of type [vector X] cannot be constructed without first
    proving that the invariant holds. *)

(** **** Exercise: 1 star, standard (a_vector) *)

(** Construct any vector of your choice. *)

Example a_vector : vector nat.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard (vector_cons_correct) *)

(** Define a cons operation on vectors. Remember to end with
    [Defined] rather than [Qed]. *)

Definition vector_cons {X : Type} (x : X) (v : vector X) : vector X.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the correctness of your cons operation. *)

Definition list_of_vector {X : Type} (v : vector X) : list X :=
  fst (proj1_sig v).

Theorem vector_cons_correct : forall (X : Type) (x : X) (v : vector X),
    list_of_vector (vector_cons x v) = x :: (list_of_vector v).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, standard (vector_app_correct) *)

(** Define an append operation on vectors. *)

Definition vector_app {X : Type} (v1 v2 : vector X) : vector X.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the correctness of your append operation. *)

Theorem vector_app_correct : forall (X : Type) (v1 v2 : vector X),
    list_of_vector (vector_app v1 v2) =
    list_of_vector v1 ++ list_of_vector v2.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Using Subset Types to Enforce the BST Invariant *)

(** Let's use subset types to reimplement tree-based tables with an
    [elements] operation.  Previously we had to add [rep_ok] to the
    interface and specifications.  With subset types we can eliminate
    that. *)

Module Type ETableSubset.

  Include Table.

  (** Note: no [rep_ok] anywhere. *)

  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Axiom bound_empty : forall (k : key),
      bound k empty = false.

  Axiom bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.

  Axiom bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETableSubset.

Module TreeETableSubset (VT : ValType) <: ETableSubset.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.

  (** [table] now is required to enforce [BST]. *)
  Definition table := { t : tree V | BST t }.

  (** Now instead of proving separate theorems that operations return
      valid representations, the proofs are "baked in" to the
      operations. *)
  Definition empty : table.
  Proof.
    apply (exist _ empty_tree).
    apply empty_tree_BST.
  Defined.

  (** Now we insert a projection to get to the tree. *)
  Definition get (k : key) (t : table) : V :=
    lookup default k (proj1_sig t).

  Definition set (k : key) (v : V) (t : table) : table.
  Proof.
    destruct t as [t Ht].
    apply (exist _ (insert k v t)).
    apply insert_BST. assumption.
  Defined.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k (proj1_sig t).

  Definition elements (t : table) : list (key * V) :=
    elements (proj1_sig t).

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty.
  Qed.

  (** Now the rest of the proofs require minor modifications to
      destruct the table to get the tree and the representation
      invariant, and use the latter where needed. *)

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_eq.
  Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_neq. assumption.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    induction t; inv Hbst; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    induction t; inv Hbst; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete with default; try assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; try assumption.
    destruct t as [t Hbst]. assumption.
  Qed.

End TreeETableSubset.

(** **** Exercise: 4 stars, advanced (ListsETable) *)

(** Implement [ETableSubset] using association lists that are not
    permitted to contain duplicate keys.  Enforce that representation
    invariant with a subset type.  Note that you do not have to keep
    the lists in a sorted order. The implementation of [elements]
    should therefore just be quite easy: just return the association
    list.  The implementation of [set], though, will have to be a
    linear-time operation. *)

(* Do not modify the following line: *)
Definition manual_grade_for_ListsETable : option (nat*string) := None.
(** [] *)

(* 2021-08-11 15:15 *)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^480 - 2^240 - 1
Base: 24
***)

Definition curve : CurveParameters :=
  {|
    sz := 20%nat;
    base := 24;
    bitwidth := 32;
    s := 2^480;
    c := [(1, 1); (2^240, 1)];
    carry_chains := Some [[9; 19]; [10; 0; 11; 1; 12; 2; 13; 3; 14; 4; 15; 5; 16; 6; 17; 7; 18; 8; 19; 9]; [10; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.