From stdpp Require Export namespaces.
From iris.algebra Require Import gmap_view namespace_map agree frac.
From iris.algebra Require Export dfrac.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.
Import uPred.

(** This file provides a generic mechanism for a language-level point-to
connective [l ↦{dq} v] reflecting the physical heap.  This library is designed to
be used as a singleton (i.e., with only a single instance existing in any
proof), with the [gen_heapG] typeclass providing the ghost names of that unique
instance.  That way, [mapsto] does not need an explicit [gname] parameter.
This mechanism can be plugged into a language and related to the physical heap
by using [gen_heap_interp σ] in the state interpretation of the weakest
precondition. See heap-lang for an example.

If you are looking for a library providing "ghost heaps" independent of the
physical state, you will likely want explicit ghost names and are thus better
off using [algebra.lib.gmap_view] together with [base_logic.lib.own].

This library is generic in the types [L] for locations and [V] for values and
supports fractional permissions.  Next to the point-to connective [l ↦{dq} v],
which keeps track of the value [v] of a location [l], this library also provides
a way to attach "meta" or "ghost" data to locations. This is done as follows:

- When one allocates a location, in addition to the point-to connective [l ↦ v],
  one also obtains the token [meta_token l ⊤]. This token is an exclusive
  resource that denotes that no meta data has been associated with the
  namespaces in the mask [⊤] for the location [l].
- Meta data tokens can be split w.r.t. namespace masks, i.e.
  [meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2] if [E1 ## E2].
- Meta data can be set using the update [meta_token l E ==∗ meta l N x] provided
  [↑N ⊆ E], and [x : A] for any countable [A]. The [meta l N x] connective is
  persistent and denotes the knowledge that the meta data [x] has been
  associated with namespace [N] to the location [l].

To make the mechanism as flexible as possible, the [x : A] in [meta l N x] can
be of any countable type [A]. This means that you can associate e.g. single
ghost names, but also tuples of ghost names, etc.

To further increase flexibility, the [meta l N x] and [meta_token l E]
connectives are annotated with a namespace [N] and mask [E]. That way, one can
assign a map of meta information to a location. This is particularly useful when
building abstractions, then one can gradually assign more ghost information to a
location instead of having to do all of this at once. We use namespaces so that
these can be matched up with the invariant namespaces. *)

(** To implement this mechanism, we use three resource algebras:

- A [gmap_view L V], which keeps track of the values of locations.
- A [gmap_view L gname], which keeps track of the meta information of
  locations. More specifically, this RA introduces an indirection: it keeps
  track of a ghost name for each location.
- The ghost names in the aforementioned authoritative RA refer to namespace maps
  [namespace_map (agree positive)], which store the actual meta information.
  This indirection is needed because we cannot perform frame preserving updates
  in an authoritative fragment without owning the full authoritative element
  (in other words, without the indirection [meta_set] would need [gen_heap_interp]
  as a premise).
 *)

(** The CMRAs we need, and the global ghost names we are using. *)

Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L} := {
  gen_heap_preG_inG :> inG Σ (gmap_viewR L (leibnizO V));
  gen_meta_preG_inG :> inG Σ (gmap_viewR L gnameO);
  gen_meta_data_preG_inG :> inG Σ (namespace_mapR (agreeR positiveO));
}.

Class gen_heapG (L V : Type) (Σ : gFunctors) `{Countable L} := GenHeapG {
  gen_heap_inG :> gen_heapPreG L V Σ;
  gen_heap_name : gname;
  gen_meta_name : gname
}.
Global Arguments GenHeapG L V Σ {_ _ _} _ _.
Global Arguments gen_heap_name {L V Σ _ _} _ : assert.
Global Arguments gen_meta_name {L V Σ _ _} _ : assert.

Definition gen_heapΣ (L V : Type) `{Countable L} : gFunctors := #[
  GFunctor (gmap_viewR L (leibnizO V));
  GFunctor (gmap_viewR L gnameO);
  GFunctor (namespace_mapR (agreeR positiveO))
].

Global Instance subG_gen_heapPreG {Σ L V} `{Countable L} :
  subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context `{Countable L, hG : !gen_heapG L V Σ}.

  Definition gen_heap_interp (σ : gmap L V) : iProp Σ := ∃ m : gmap L gname,
    (* The [⊆] is used to avoid assigning ghost information to the locations in
    the initial heap (see [gen_heap_init]). *)
    ⌜ dom _ m ⊆ dom (gset L) σ ⌝ ∧
    own (gen_heap_name hG) (gmap_view_auth 1 (σ : gmap L (leibnizO V))) ∗
    own (gen_meta_name hG) (gmap_view_auth 1 (m : gmap L gnameO)).

  Definition mapsto_def (l : L) (dq : dfrac) (v: V) : iProp Σ :=
    own (gen_heap_name hG) (gmap_view_frag l dq (v : leibnizO V)).
  Definition mapsto_aux : seal (@mapsto_def). Proof. by eexists. Qed.
  Definition mapsto := mapsto_aux.(unseal).
  Definition mapsto_eq : @mapsto = @mapsto_def := mapsto_aux.(seal_eq).

  Definition meta_token_def (l : L) (E : coPset) : iProp Σ :=
    ∃ γm, own (gen_meta_name hG) (gmap_view_frag l DfracDiscarded γm) ∗
          own γm (namespace_map_token E).
  Definition meta_token_aux : seal (@meta_token_def). Proof. by eexists. Qed.
  Definition meta_token := meta_token_aux.(unseal).
  Definition meta_token_eq : @meta_token = @meta_token_def := meta_token_aux.(seal_eq).

  Definition meta_def `{Countable A} (l : L) (N : namespace) (x : A) : iProp Σ :=
    ∃ γm, own (gen_meta_name hG) (gmap_view_frag l DfracDiscarded γm) ∗
          own γm (namespace_map_data N (to_agree (encode x))).
  Definition meta_aux : seal (@meta_def). Proof. by eexists. Qed.
  Definition meta := meta_aux.(unseal).
  Definition meta_eq : @meta = @meta_def := meta_aux.(seal_eq).
End definitions.
Global Arguments meta {L _ _ V Σ _ A _ _} l N x.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Local Notation "l ↦{ dq } v" := (mapsto l dq v)
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Local Notation "l ↦□ v" := (mapsto l DfracDiscarded v)
  (at level 20, format "l  ↦□  v") : bi_scope.
Local Notation "l ↦{# q } v" := (mapsto l (DfracOwn q) v)
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section gen_heap.
  Context {L V} `{Countable L, !gen_heapG L V Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : V → iProp Σ.
  Implicit Types σ : gmap L V.
  Implicit Types m : gmap L gname.
  Implicit Types l : L.
  Implicit Types v : V.

  (** General properties of mapsto *)
  Global Instance mapsto_timeless l dq v : Timeless (l ↦{dq} v).
  Proof. rewrite mapsto_eq. apply _. Qed.
  Global Instance mapsto_fractional l v : Fractional (λ q, l ↦{#q} v)%I.
  Proof.
    intros p q. rewrite mapsto_eq /mapsto_def -own_op gmap_view_frag_add //.
  Qed.
  Global Instance mapsto_as_fractional l q v :
    AsFractional (l ↦{#q} v) (λ q, l ↦{#q} v)%I q.
  Proof. split; [done|]. apply _. Qed.
  Global Instance mapsto_persistent l v : Persistent (l ↦□ v).
  Proof. rewrite mapsto_eq. apply _. Qed.

  Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝%Qp.
  Proof.
    rewrite mapsto_eq. iIntros "Hl".
    iDestruct (own_valid with "Hl") as %?%gmap_view_frag_valid. done.
  Qed.
  Lemma mapsto_valid_2 l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof.
    rewrite mapsto_eq. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %[??]%gmap_view_frag_op_valid_L.
    auto.
  Qed.
  (** Almost all the time, this is all you really need. *)
  Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (mapsto_valid_2 with "H1 H2") as %[_ ?].
    done.
  Qed.

  Lemma mapsto_combine l dq1 dq2 v1 v2 :
    l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (mapsto_agree with "Hl1 Hl2") as %->.
    iCombine "Hl1 Hl2" as "Hl".
    rewrite mapsto_eq /mapsto_def -own_op gmap_view_frag_op.
    auto.
  Qed.

  Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
    ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof.
    iIntros (?) "Hl1 Hl2"; iIntros (->).
    by iDestruct (mapsto_valid_2 with "Hl1 Hl2") as %[??].
  Qed.
  Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof. apply mapsto_frac_ne. intros ?%exclusive_l; [done|apply _]. Qed.

  (** Permanently turn any points-to predicate into a persistent
      points-to predicate. *)
  Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v.
  Proof. rewrite mapsto_eq. apply own_update, gmap_view_persist. Qed.

  (** General properties of [meta] and [meta_token] *)
  Global Instance meta_token_timeless l N : Timeless (meta_token l N).
  Proof. rewrite meta_token_eq /meta_token_def. apply _. Qed.
  Global Instance meta_timeless `{Countable A} l N (x : A) : Timeless (meta l N x).
  Proof. rewrite meta_eq /meta_def. apply _. Qed.
  Global Instance meta_persistent `{Countable A} l N (x : A) : Persistent (meta l N x).
  Proof. rewrite meta_eq /meta_def. apply _. Qed.

  Lemma meta_token_union_1 l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) -∗ meta_token l E1 ∗ meta_token l E2.
  Proof.
    rewrite meta_token_eq /meta_token_def. intros ?. iDestruct 1 as (γm1) "[#Hγm Hm]".
    rewrite namespace_map_token_union //. iDestruct "Hm" as "[Hm1 Hm2]".
    iSplitL "Hm1"; eauto.
  Qed.
  Lemma meta_token_union_2 l E1 E2 :
    meta_token l E1 -∗ meta_token l E2 -∗ meta_token l (E1 ∪ E2).
  Proof.
    rewrite meta_token_eq /meta_token_def.
    iDestruct 1 as (γm1) "[#Hγm1 Hm1]". iDestruct 1 as (γm2) "[#Hγm2 Hm2]".
    iDestruct (own_valid_2 with "Hγm1 Hγm2") as %[_ ->]%gmap_view_frag_op_valid_L.
    iDestruct (own_valid_2 with "Hm1 Hm2") as %?%namespace_map_token_valid_op.
    iExists γm2. iFrame "Hγm2". rewrite namespace_map_token_union //. by iSplitL "Hm1".
  Qed.
  Lemma meta_token_union l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2.
  Proof.
    intros; iSplit; first by iApply meta_token_union_1.
    iIntros "[Hm1 Hm2]". by iApply (meta_token_union_2 with "Hm1 Hm2").
  Qed.

  Lemma meta_token_difference l E1 E2 :
    E1 ⊆ E2 → meta_token l E2 ⊣⊢ meta_token l E1 ∗ meta_token l (E2 ∖ E1).
  Proof.
    intros. rewrite {1}(union_difference_L E1 E2) //.
    by rewrite meta_token_union; last set_solver.
  Qed.

  Lemma meta_agree `{Countable A} l i (x1 x2 : A) :
    meta l i x1 -∗ meta l i x2 -∗ ⌜x1 = x2⌝.
  Proof.
    rewrite meta_eq /meta_def.
    iDestruct 1 as (γm1) "[Hγm1 Hm1]"; iDestruct 1 as (γm2) "[Hγm2 Hm2]".
    iDestruct (own_valid_2 with "Hγm1 Hγm2") as %[_ ->]%gmap_view_frag_op_valid_L.
    iDestruct (own_valid_2 with "Hm1 Hm2") as %Hγ; iPureIntro.
    move: Hγ. rewrite -namespace_map_data_op namespace_map_data_valid.
    move=> /to_agree_op_inv_L. naive_solver.
  Qed.
  Lemma meta_set `{Countable A} E l (x : A) N :
    ↑ N ⊆ E → meta_token l E ==∗ meta l N x.
  Proof.
    rewrite meta_token_eq meta_eq /meta_token_def /meta_def.
    iDestruct 1 as (γm) "[Hγm Hm]". iExists γm. iFrame "Hγm".
    iApply (own_update with "Hm"). by apply namespace_map_alloc_update.
  Qed.

  (** Update lemmas *)
  Lemma gen_heap_alloc σ l v :
    σ !! l = None →
    gen_heap_interp σ ==∗ gen_heap_interp (<[l:=v]>σ) ∗ l ↦ v ∗ meta_token l ⊤.
  Proof.
    iIntros (Hσl). rewrite /gen_heap_interp mapsto_eq /mapsto_def meta_token_eq /meta_token_def /=.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iMod (own_update with "Hσ") as "[Hσ Hl]".
    { eapply (gmap_view_alloc _ l (DfracOwn 1)); done. }
    iMod (own_alloc (namespace_map_token ⊤)) as (γm) "Hγm".
    { apply namespace_map_token_valid. }
    iMod (own_update with "Hm") as "[Hm Hlm]".
    { eapply (gmap_view_alloc _ l DfracDiscarded); last done.
      move: Hσl. rewrite -!(not_elem_of_dom (D:=gset L)). set_solver. }
    iModIntro. iFrame "Hl". iSplitL "Hσ Hm"; last by eauto with iFrame.
    iExists (<[l:=γm]> m). iFrame. iPureIntro.
    rewrite !dom_insert_L. set_solver.
  Qed.

  Lemma gen_heap_alloc_big σ σ' :
    σ' ##ₘ σ →
    gen_heap_interp σ ==∗
    gen_heap_interp (σ' ∪ σ) ∗ ([∗ map] l ↦ v ∈ σ', l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ', meta_token l ⊤).
  Proof.
    revert σ; induction σ' as [| l v σ' Hl IH] using map_ind; iIntros (σ Hdisj) "Hσ".
    { rewrite left_id_L. auto. }
    iMod (IH with "Hσ") as "[Hσ'σ Hσ']"; first by eapply map_disjoint_insert_l.
    decompose_map_disjoint.
    rewrite !big_opM_insert // -insert_union_l //.
    by iMod (gen_heap_alloc with "Hσ'σ") as "($ & $ & $)";
      first by apply lookup_union_None.
  Qed.

  Lemma gen_heap_valid σ l dq v : gen_heap_interp σ -∗ l ↦{dq} v -∗ ⌜σ !! l = Some v⌝.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ _]". iIntros "Hl".
    rewrite /gen_heap_interp mapsto_eq.
    by iDestruct (own_valid_2 with "Hσ Hl") as %[??]%gmap_view_both_valid_L.
  Qed.

  Lemma gen_heap_update σ l v1 v2 :
    gen_heap_interp σ -∗ l ↦ v1 ==∗ gen_heap_interp (<[l:=v2]>σ) ∗ l ↦ v2.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iIntros "Hl". rewrite /gen_heap_interp mapsto_eq /mapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl") as %[_ Hl]%gmap_view_both_valid_L.
    iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]".
    { eapply gmap_view_update. }
    iModIntro. iFrame "Hl". iExists m. iFrame.
    iPureIntro. apply (elem_of_dom_2 (D:=gset L)) in Hl.
    rewrite dom_insert_L. set_solver.
  Qed.
End gen_heap.

(** This variant of [gen_heap_init] should only be used when absolutely needed.
The key difference to [gen_heap_init] is that the [inG] instances in the new
[gen_heapG] instance are related to the original [gen_heapPreG] instance,
whereas [gen_heap_init] forgets about that relation. *)
Lemma gen_heap_init_names `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ γh γm : gname,
    let hG := GenHeapG L V Σ γh γm in
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (own_alloc (gmap_view_auth 1 (∅ : gmap L (leibnizO V)))) as (γh) "Hh".
  { exact: gmap_view_auth_valid. }
  iMod (own_alloc (gmap_view_auth 1 (∅ : gmap L gnameO))) as (γm) "Hm".
  { exact: gmap_view_auth_valid. }
  iExists γh, γm.
  iAssert (gen_heap_interp (hG:=GenHeapG _ _ _ γh γm) ∅) with "[Hh Hm]" as "Hinterp".
  { iExists ∅; simpl. iFrame "Hh Hm". by rewrite dom_empty_L. }
  iMod (gen_heap_alloc_big with "Hinterp") as "(Hinterp & $ & $)".
  { apply map_disjoint_empty_r. }
  rewrite right_id_L. done.
Qed.

Lemma gen_heap_init `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ _ : gen_heapG L V Σ,
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (gen_heap_init_names σ) as (γh γm) "Hinit".
  iExists (GenHeapG _ _ _ γh γm).
  done.
Qed.


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.

Arguments wkm _ {_ _} _.
Arguments comp _ _ {_ _ } _ _ _.

Record WtRen (Γ Δ: Env) (ζ: Sub Ix) : Prop :=
  { wtr_tyvar : ∀ {α k},
                  ⟨ α ∷ k ∈ Γ ⟩ →
                  ⟨ ζ α ∷ k ∈ Δ ⟩;
    wtr_covar : ∀ {c τ1 τ2 k},
                  ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
                  ⟨ ζ c : τ1[ζ] ~ τ2[ζ] ∷ k ∈ Δ ⟩;
    wtr_tmvar : ∀ {x τ},
                  ⟨ x : τ ∈ Γ ⟩ →
                  ⟨ ζ x : τ[ζ] ∈ Δ ⟩
  }.

Notation "⟨ ζ : Γ -> Δ ⟩" := (WtRen Γ Δ ζ)
  (at level 0,
   ζ at level 98,
   Γ at level 98,
   Δ at level 98).

Arguments wtr_tyvar {_ _ _} _ {_ _} _.
Arguments wtr_covar {_ _ _} _ {_ _ _ _} _.
Arguments wtr_tmvar {_ _ _} _ {_ _} _.

Record WtSub (Γ Δ: Env) (ζ: Sub Exp) : Prop :=
  { wts_tyvar : ∀ {α k},
                  ⟨ α ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ α ∷ k ⟩;
    wts_covar : ∀ {c τ1 τ2 k},
                  ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ c : τ1[ζ] ~ τ2[ζ] ∷ k ⟩;
    wts_tmvar : ∀ {x τ},
                  ⟨ x : τ ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ x : τ[ζ] ⟩;
  }.
Notation "⟨ ζ : Γ => Δ ⟩" := (WtSub Γ Δ ζ)
  (at level 0, ζ at level 98, Γ at level 98, Δ at level 98).

Arguments wts_tyvar {_ _ _} _ {_ _} _.
Arguments wts_covar {_ _ _} _ {_ _ _ _} _.
Arguments wts_tmvar {_ _ _} _ {_ _} _.

Hint Constructors Ty : ws.
Hint Constructors Co : ws.
Hint Constructors Red : ws.
Hint Constructors RedStar : ws.
Hint Constructors Tm : ws.
Hint Resolve wtr_tyvar : ws.
Hint Resolve wtr_covar : ws.
Hint Resolve wtr_tmvar : ws.
Hint Resolve wts_tyvar : ws.
Hint Resolve wts_covar : ws.
Hint Resolve wts_tmvar : ws.

(* Lemma getEvarInvHere { Γ T U } : *)
(*   ⟪ 0 : T ∈ (Γ ▻ U) ⟫ → T = U. *)
(* Proof. inversion 1; auto. Qed. *)

(* Lemma getEvarInvThere {Γ i T U} : *)
(*   ⟪ (S i) : T ∈ Γ ▻ U ⟫ → ⟪ i : T ∈ Γ ⟫. *)
(* Proof. inversion 1; auto. Qed. *)
(* Hint Resolve getEvarInvThere : wsi. *)

Ltac crushTypingMatchH :=
  match goal with
    | [H: ⟨ 0 : _ ∈ _ ⟩                    |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) : _ ∈ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ 0 ∷ _ ∈ _ ⟩                    |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) ∷ _ ∈ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ 0 : _ ~ _ ∷ _ ∈ _ ⟩            |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) : _ ~ _ ∷ _ ∈ _ ⟩        |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ : _ ∈ nil ⟩                  |- _] => inversion H; clear H; subst*
    (* Ty *)
    | [H: ⟨ _ ⊢ var _ ∷ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ τabs _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ τapp _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arr _ _ ∷ _ ⟩              |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arrτ _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arrγ _ _ _ _ ∷ _ ⟩         |- _] => inversion H; clear H; subst*
    (* Co *)
    | [H: ⟨ _ ⊢ var _          : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτabs _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτapp _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarr _ _      : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarrτ _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarrγ _ _ _ _ : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarr₁ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarr₂ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrτ _ _  : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₁ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₂ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₂ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cobeta _ _ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ corefl _       : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cosym _        : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cotrans _ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    (* Red *)
    | [H: ⟨ _ ⊢ var _ : _ ↝ _ ∷ _ ⟩        |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτabs _ _ : _ ↝ _ ∷ _ ⟩   |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arr _ _ ↝ _ ∷ _ ⟩      |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arrτ _ _ ↝ _ ∷ _ ⟩     |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arrγ _ _ _ _ ↝ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    (* Tm *)
    | [H: ⟨ _ ⊢ var _ : _        ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ abs _ _ : _      ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ absτ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ absγ _ _ _ _ : _ ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ app _ _ : _      ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ appτ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ appγ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cast _ _ : _     ⟩         |- _] => inversion H; clear H; subst*

    (* | [ wi : ⟪ ?i : _ ∈ (_ ▻ _) ⟫ *)
    (*     |- context [match ?i with _ => _ end] *)
    (*   ] => destruct i *)
    | [ wi : ⟨ ?i : _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ► _) ⟩ |- _] => inversion wi; clear wi
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *

    | [ |- ⟨ _ ⊢ (_ :: _) : _ ↝* _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ nil : _ ↝* _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ coarrγ _ _ _ _ : _ ↝ _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ _ : arrγ _ _ _ _ ↝ _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ cotrans _ _ : _ ~ _ ∷ _ ⟩ ] => econstructor

    (* | [ wi : ⟨ ?i : _ ∈ (_ ► _) ⟩ *)
    (*     |- context [(_ · _) ?i] *)
    (*   ] => destruct i eqn: ?; cbn in * *)
    (* | [ wi : ⟨ ?i : _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ *)
    (*     |- context [(_ · _) ?i] *)
    (*   ] => destruct i eqn: ?; cbn in * *)
    (* | [ |- ⟪ _ ⊢ var _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ abs _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ app _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ unit : _ ⟫          ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ true : _ ⟫          ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ false : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ ite _ _ _ : _ ⟫     ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ pair _ _ : _ ⟫      ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ proj₁ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ proj₂ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ inl _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ inr _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ caseof _ _ _ : _ ⟫  ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ seq _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ fixt _ _ _ : _ ⟫    ] => econstructor *)
  end.

Hint Constructors GetTyVar : ws.
Hint Constructors GetCoVar : ws.
Hint Constructors GetTmVar : ws.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
     repeat crushSyntaxMatch;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     (* repeat crushTypingMatchH; *)
     subst*;
     try discriminate;
     eauto 200 with core ws;
     idtac
    ).

(*************************************************************************)

Lemma wtRen_closed {ζ Δ} :
  ⟨ ζ : nil -> Δ ⟩.
Proof. constructor; inversion 1. Qed.
Hint Resolve wtRen_closed : ws.

Lemma wtRen_idm Γ :
  ⟨ idm Ix : Γ -> Γ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtRen_idm : ws.

Lemma wtRen_comp {Γ₁ Γ₂ Γ₃ ξ₁ ξ₂} :
  ⟨ ξ₁ : Γ₁ -> Γ₂ ⟩ →
  ⟨ ξ₂ : Γ₂ -> Γ₃ ⟩ →
  ⟨ ξ₁ >=> ξ₂ : Γ₁ -> Γ₃ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtRen_comp : ws.

(*************************************************************************)

Lemma wtRen_wkm_tyvar Γ k :
  ⟨ wkm Ix : Γ -> Γ ► k ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_tyvar : ws.

Lemma wtRen_wkm_covar Γ τ1 τ2 k :
  ⟨ wkm Ix : Γ -> Γ ◅ τ1 ~ τ2 ∷ k ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_covar : ws.

Lemma wtRen_wkm_tmvar Γ τ :
  ⟨ wkm Ix : Γ -> Γ ▻ τ ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_tmvar : ws.

Lemma wtRen_snoc_tyvar {Γ Δ ζ α k} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ α ∷ k ∈ Δ ⟩ →
  ⟨ ζ · α : Γ ► k -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_tyvar : ws.

Lemma wtRen_snoc_covar {Γ Δ ζ c τ1 τ2 k} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ c : τ1[ζ] ~ τ2[ζ] ∷ k ∈ Δ ⟩ →
  ⟨ ζ · c : Γ ◅ τ1 ~ τ2 ∷ k -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_covar : ws.

Lemma wtRen_snoc_tmvar {Γ Δ ζ x τ} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ x : τ[ζ] ∈ Δ ⟩ →
  ⟨ ζ · x : Γ ▻ τ -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_tmvar : ws.

Lemma wtRen_up_tyvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ k, ⟨ ζ↑ : Γ₁ ► k -> Γ₂ ► k ⟩.
Proof. rewrite up_def. constructor; crush. Qed.
Hint Resolve wtRen_up_tyvar : ws.

Lemma wtRen_up_covar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ τ1 τ2 k, ⟨ ζ↑ : Γ₁ ◅ τ1 ~ τ2 ∷ k -> Γ₂ ◅ τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
  - inversion H; clear H; crush.
    + rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
      constructor.
    + rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
      constructor.
      now apply (wtr_covar wζ).
  - inversion H; clear H; crush.
    rewrite <- (ap_wkm_ix (X:=Exp)), ap_comp.
    rewrite wkm_snoc_cancel.
    rewrite <- ap_comp, (ap_wkm_ix (X:=Exp)).
    constructor.
    now apply (wtr_tmvar wζ).
Qed.
Hint Resolve wtRen_up_covar : ws.

Lemma wtRen_up_tmvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ τ, ⟨ ζ↑ : Γ₁ ▻ τ -> Γ₂ ▻ τ[ζ] ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
  - inversion H; clear H; crush.
    rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
    constructor.
    now apply (wtr_covar wζ).
  - inversion H; clear H; crush.
    + rewrite <- ap_wkm_ix, ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp, ap_wkm_ix.
      constructor.
    + rewrite <- (ap_wkm_ix (X:=Exp)) , ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp, (ap_wkm_ix (X:=Exp)).
      constructor.
      now apply (wtr_tmvar wζ).
Qed.
Hint Resolve wtRen_up_tmvar : ws.

Lemma ty_ren {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ τ[ζ] ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve ty_ren : ws.

Lemma co_ren {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
Qed.
Hint Resolve co_ren : ws.

Lemma red_ren {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ↝ τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
Qed.
Hint Resolve red_ren : ws.

Lemma redstar_ren {Γ γs τ1 τ2 k} (wγ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γs[ζ] : τ1[ζ] ↝* τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
Qed.
Hint Resolve redstar_ren : ws.

Lemma tm_ren {Γ s τ} (wt: ⟨ Γ ⊢ s : τ ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ s[ζ] : τ[ζ] ⟩.
Proof.
  induction wt; intros ? ζ wζ; crush.
  - constructor; crush.
    rewrite <- ap_wkm_ix.
    rewrite apply_wkm_comm.
    rewrite ap_wkm_ix.
    apply IHwt; crush.
  - constructor; crush.
    rewrite <- ap_wkm_ix.
    rewrite apply_wkm_comm.
    rewrite ap_wkm_ix.
    apply IHwt; crush.
  - rewrite <- ?ap_liftSub.
    rewrite apply_beta1_comm.
    rewrite up_liftSub.
    rewrite ?ap_liftSub.
    crush.
  - econstructor; crush.
Qed.
Hint Resolve tm_ren : ws.

(*************************************************************************)

Lemma wtSub_closed ζ Δ : ⟨ ζ : nil => Δ ⟩.
Proof. constructor; inversion 1. Qed.
Hint Resolve wtSub_closed : ws.

Lemma wtSub_idm (Γ: Env) : ⟨ idm Exp : Γ => Γ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_idm : ws.

Lemma wtSub_wkm_tyvar Γ k :
  ⟨ wkm Exp : Γ => Γ ► k ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_tyvar : ws.

Lemma wtSub_wkm_covar Γ τ1 τ2 k :
  ⟨ wkm Exp : Γ => Γ ◅ τ1 ~ τ2 ∷ k ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_covar : ws.

Lemma wtSub_wkm_tmvar Γ τ :
  ⟨ wkm Exp : Γ => Γ ▻ τ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_tmvar : ws.

Lemma wtSub_snoc_tyvar {Γ Δ ζ τ k} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ τ ∷ k ⟩ →
  ⟨ ζ · τ : Γ ► k => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_tyvar : ws.

Lemma wtSub_snoc_covar {Γ Δ ζ γ τ1 τ2 k} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ γ : τ1[ζ] ~ τ2[ζ] ∷ k ⟩ →
  ⟨ ζ · γ : Γ ◅ τ1 ~ τ2 ∷ k => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_covar : ws.

Lemma wtSub_snoc_tmvar {Γ Δ ζ s τ} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ s : τ[ζ] ⟩ →
  ⟨ ζ · s : Γ ▻ τ => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_tmvar : ws.

Lemma wtSub_up_tyvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ k, ⟨ ζ↑ : Γ₁ ► k => Γ₂ ► k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ap_wkm_ix; crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
Qed.
Hint Resolve wtSub_up_tyvar : ws.

Lemma wtSub_up_covar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ τ1 τ2 k, ⟨ ζ↑ : Γ₁ ◅ τ1 ~ τ2 ∷ k => Γ₂ ◅ τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ap_wkm_ix; crush.
  - inversion H; clear H; crush.
    + constructor.
      rewrite ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp.
      constructor.
    + rewrite ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp.
      rewrite <- ?(ap_wkm_ix (X:=Exp)).
      crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
Qed.
Hint Resolve wtSub_up_covar : ws.

Lemma wtSub_up_tmvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ τ, ⟨ ζ↑ : Γ₁ ▻ τ => Γ₂ ▻ τ[ζ] ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    + rewrite ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp.
      repeat constructor.
    + rewrite ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp.
      rewrite <- ?(ap_wkm_ix (X:=Exp)).
      crush.
Qed.
Hint Resolve wtSub_up_tmvar : ws.

Lemma ty_sub {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ τ[ζ] ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve ty_sub : ws.

Lemma co_sub {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof. induction wγ; crush. Qed.
Hint Resolve co_sub : ws.

Lemma tm_sub {Γ s τ} (wt: ⟨ Γ ⊢ s : τ ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ s[ζ] : τ[ζ] ⟩.
Proof.
  induction wt; intros ? ζ wζ; crush.
  - constructor; crush.
  - constructor; crush.
  - econstructor; crush.
Qed.
Hint Resolve tm_sub : ws.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef3.Specs.data_destroy3.
Require Import TableDataOpsRef3.LowSpecs.data_destroy3.
Require Import TableDataOpsRef3.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       data_destroy_spec
       data_destroy2_spec
    .

  Lemma data_destroy3_spec_exists:
    forall habd habd'  labd g_rd map_addr res
      (Hspec: data_destroy3_spec g_rd map_addr habd = Some (habd', res))
      (Hrel: relate_RData habd labd),
    exists labd', data_destroy3_spec0 g_rd map_addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    Local Opaque peq ptr_eq.
    intros. duplicate Hrel. destruct D. clear hrepl lrepl. destruct g_rd.
    unfold data_destroy3_spec, data_destroy3_spec0 in *.
    unfold Assertion in *. rm_bind Hspec; rm_bind'. simpl in *.
    unfold Assertion; rm_bind'; grewrite.
    repeat simpl_hyp Hspec; extract_prop_dec; simpl_query_oracle; rm_bind'; grewrite.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl).
      assert(Hwalk: repl habd (oracle habd
                                      (EVT CPU_ID (RTT_WALK (g_rtt (gnorm (gs (share habd)) @ z)) z0 3) :: oracle habd (log habd) ++ log habd))
                         s {gs : (gs s) # llt_gidx == (((gs s) @ llt_gidx) {glock : Some CPU_ID})} =
                    Some (s {gs : (gs s) # llt_gidx == (((gs s) @ llt_gidx) {glock : Some CPU_ID})})).
      destruct Hrel. grewrite. destruct valid_ho0. rewrite Hright_log_nil. reflexivity.
      eapply RightLogMover.
      apply walk_right. omega. omega. apply RightLogOracle. simpl.
      rewrite_oracle_rel rel_oracle Hwalk; simpl in *.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
      rewrite <- Prop4. simpl_field.
      assert(data_gidx <> llt_gidx). red; intro T; rewrite T in *. bool_rel. autounfold in *. omega.
      repeat rewrite (zmap_comm _ _ H). repeat (try simpl_htarget; repeat simpl_field; repeat swap_fields).
      reflexivity.
    - repeat destruct_con.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl). simpl_htarget.
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity. simpl_htarget. reflexivity.
    - repeat destruct_con.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      rewrite_oracle_rel rel_oracle C2; simpl in *.
      repeat (grewrite; simpl). simpl_htarget.
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat destruct_con.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
    - rewrite_oracle_rel rel_oracle C2.
      repeat (grewrite; simpl).
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec. eexists; split. reflexivity.
      constructor; destruct Hrel; simpl; try assumption; try reflexivity.
  Qed.

End Refine.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import malloc macros.
From cap_machine Require Import fundamental logrel macros_helpers rules proofmode.
From cap_machine.examples Require Import template_adequacy.
From cap_machine Require Import register_tactics.
Open Scope Z_scope.

(** Exercise - the region is already allocated and the capability pointing to this
    region is in R1. As a first step, the adversary code is known and just halts. *)
Section base_program.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (** r_mem is the register that contains the capability pointing to
      the allocated buffer
      secret_off is the offset of the secret in the buffer
      secret is the value stored in the buffer
   *)
  Definition prog_base_instrs r_mem (secret_off secret : Z) : list Word :=
    encodeInstrsW [
      Lea r_mem secret_off ;
      Store r_mem secret ;
      GetB r_t2 r_mem ;
      GetE r_t3 r_mem ;
      Add r_t2 r_t2 (secret_off + 1) ;
      Subseg r_mem r_t2 r_t3
      ].

  (** Jump to the adversary in register r30 at the end of the program *)
  Definition prog_code secret_off secret_val: list Word :=
    prog_base_instrs r_t1 secret_off secret_val ++ encodeInstrsW [Jmp r_t30].

  (** The adversary code is known --- it just halts *)
  Definition adv_code : list Word :=
    encodeInstrsW [ Halt ].

  (** Specification of :
      - executes the first part
      - jump to the adversary
      - halts
   *)
  Lemma prog_spec (a_adv: Addr)
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        secret_off secret_val
        w2 w3 :
    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog len_p ->

    (b_mem <= secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    ⊢ ( (* PC points to prog_code*)
        PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ codefrag a_prog (prog_code secret_off secret_val)
        (* r1 points to the allocated memory*)
        ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
        (* which is filled by zeroes *)
        ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
        (* r30 point to the adversary code *)
        ∗ r_t30 ↦ᵣ WCap E a_adv (a_adv ^+ (length adv_code))%a a_adv
        ∗ codefrag a_adv adv_code
        ∗ r_t2 ↦ᵣ w2
        ∗ r_t3 ↦ᵣ w3
        -∗ WP Seq (Instr Executable) {{
                λ v, ⌜v = HaltedV⌝ -∗ (* The machine is halted after the adversary *)
                     r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a
                     ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1))
                     ∗ r_t3 ↦ᵣ WInt e_mem
                     ∗ codefrag a_prog (prog_code secret_off secret_val)
                     ∗ codefrag a_adv adv_code
                     ∗ secret ↦ₐ WInt secret_val
                     ∗ [[b_mem, secret]] ↦ₐ [[ region_addrs_zeroes b_mem secret]]
                     ∗ [[(secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret^+1)%a e_mem ]]
      }})%I.

  Proof.
    intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr30& Hadv& Hr2& Hr3)".

    (* 1 - prepare the assertions for the proof *)
    subst secret len_p.
    (* Derives the facts from the codefrag *)
    codefrag_facts "Hprog".
    codefrag_facts "Hadv".
    simpl in *.
    rewrite /prog_code.
    (* This assertion will be helpful seeral times during the proof *)
    assert (Hp_mem': ~ p_mem = E)
           by (intros -> ; simpl in Hp_mem ; discriminate).

    (* 2 - Use the WP rules for each instructions *)
    (* Lea r_t1 3 *)
    iInstr "Hprog".
    { transitivity (Some (b_mem ^+secret_off)%a) ; auto. solve_addr. }
    (* Store r_t1 42 , where r_t1 = (RWX, b, e, secret) *)
    (* The store requires the resource `secret ↦ₐ w` for some w,
       we thus extract the resource from the memory buffer *)
    rewrite (region_addrs_zeroes_split b_mem (b_mem ^+secret_off)%a e_mem)
    ; [| solve_addr].
    iDestruct (region_mapsto_split
                 b_mem e_mem
                 (b_mem ^+secret_off)%a
                 (region_addrs_zeroes b_mem (b_mem ^+secret_off)%a)
                 (region_addrs_zeroes (b_mem ^+secret_off)%a e_mem)
                with "Hmem") as "[Hmem Hmem']".
    { solve_addr. }
    { unfold region_addrs_zeroes. by rewrite replicate_length. }
    unfold region_addrs_zeroes at 2.
    rewrite finz_dist_S ; [|solve_addr].
    rewrite replicate_S.
    iDestruct (region_mapsto_cons (b_mem ^+secret_off)%a _ e_mem (WInt 0)
                                   (region_addrs_zeroes _ e_mem)
                with "Hmem'") as "[Hsecret Hmem']".
    { transitivity (Some (b_mem ^+(secret_off +1))%a) ; auto. solve_addr. }
    { solve_addr. }
    (* Now that we have the secret address, we can continue *)
    iInstr "Hprog".
    { solve_addr. }
    (* getB, getE, add, subseg *)
    iGo "Hprog".
    { transitivity (Some (b_mem ^+(secret_off+1))%a) ; auto. solve_addr. }
    { solve_addr. }
    (* jmp *)
    iInstr "Hprog".
    (* halts in the adversary code *)
    rewrite /adv_code.
    iInstr "Hadv".

    (* 3 - The machine is halted, prove that the post condition holds *)
    wp_end.
    iIntros "_".
    replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr.
    iFrame.
  Qed.

End base_program.

(** We use a CPS specification. We don't know the adversary code,
    thus we stop the specification after the jump. We give only the necessary
    ressources. *)
Section base_program_CPS.

  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg : sealStoreG Σ}
          `{MP: MachineParameters}.

  Local Ltac solve_addr' :=
    repeat match goal with x := _ |- _ => subst x end
    ; solve_addr.

  Local Ltac iGo' hprog :=
    repeat
    (iGo hprog ;
    try (
    match goal with
    | h: _ |- isCorrectPC _ =>
        apply isCorrectPC_ExecPCPerm_InBounds ; auto; solve_addr'
    end)
    ; try solve_addr').

  (** Specification of the program before the jump to the adversary.
      The specification and the proof are essentially the same as the
      previous one. *)
  Lemma prog_base_spec
        r_mem secret_off secret (* instantiation prog_base *)
        p_pc b_pc e_pc s_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w2 w3
        φ :

    let e_prog := (s_prog ^+ length (prog_base_instrs r_mem secret_off secret))%a in
    let a_secret := (b_mem ^+ secret_off)%a in

    (* Validity pc *)
    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc s_prog e_prog ->

    (* Validity buffer *)
    ( b_mem <= a_secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    (* Specification *)
    ⊢ (( PC ↦ᵣ WCap p_pc b_pc e_pc s_prog
         ∗ r_mem ↦ᵣ WCap p_mem b_mem e_mem b_mem
         ∗ r_t2 ↦ᵣ w2
         ∗ r_t3 ↦ᵣ w3
         ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
         ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret)
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
               ∗ r_mem ↦ᵣ WCap p_mem (a_secret^+1)%a e_mem a_secret
               ∗ r_t2 ↦ᵣ WInt (b_mem+secret_off+1)
               ∗ r_t3 ↦ᵣ WInt e_mem
               ∗ [[b_mem, a_secret]] ↦ₐ [[ region_addrs_zeroes b_mem a_secret ]]
               ∗ a_secret ↦ₐ WInt secret
               ∗ [[(a_secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (a_secret^+1)%a e_mem ]]
               ∗ codefrag s_prog (prog_base_instrs r_mem secret_off secret)
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof with (try solve_addr').
    intros e_prog a_secret.
    iIntros (Hpc_perm Hpc_bounds Hsecret_bounds Hp_mem)
            "(HPC & Hr_mem & Hr2 & Hr3 & Hmem & Hprog & Post)".
    rewrite /region_mapsto.
    codefrag_facts "Hprog".
    iGo' "Hprog".
    { transitivity (Some (b_mem ^+ secret_off)%a) ; auto ; solve_addr'. }
    { intros -> ; simpl in Hp_mem ; discriminate. }

    rewrite (region_addrs_zeroes_split b_mem a_secret e_mem)...
    iDestruct (region_mapsto_split
                 b_mem e_mem
                 a_secret
                 (region_addrs_zeroes b_mem a_secret)
                 (region_addrs_zeroes a_secret e_mem)
                with "Hmem") as "[Hmem Hmem']"...
    { unfold region_addrs_zeroes. by rewrite replicate_length. }
    unfold region_addrs_zeroes at 4.
    rewrite finz_dist_S...
    rewrite replicate_S.
    iDestruct (region_mapsto_cons a_secret (a_secret ^+1)%a e_mem (WInt 0)
                                   (region_addrs_zeroes _ e_mem)
                with "Hmem'") as "[Hsecret Hmem']"...
    iGo' "Hprog".
    (* getB getE add subseg *)
    { transitivity (Some (b_mem ^+ (secret_off + 1))%a) ; auto... }
    { intros -> ; simpl in Hp_mem ; discriminate. }
    { solve_addr'. }

    (* Post condition *)
    iApply "Post".
    subst e_prog; simpl in *.
    replace (b_mem ^+ (secret_off + 1))%a with (a_secret ^+ 1)%a by solve_addr'.
    replace (b_mem + secret_off + 1) with (b_mem + (secret_off + 1)) by lia.
    iFrame.
  Qed.

  (** Specification of the program until the jump to the unknown adversary code *)
  Lemma prog_spec_CPS
        wadv
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w2 w3
        secret_off secret_val
        φ :
    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog len_p ->

    (b_mem <= secret < e_mem)%a ->
    writeAllowed p_mem = true ->

    ⊢ ( (* PC points to prog_code*)
        ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ codefrag a_prog (prog_code secret_off secret_val)
          (* r1 points to the allocated memory*)
          ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
          (* which is filled by zeroes *)
          ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
          (* r30 point to the adversary code *)
          ∗ r_t30 ↦ᵣ wadv
          ∗ r_t2 ↦ᵣ w2
          ∗ r_t3 ↦ᵣ w3
          ∗ ▷ ( PC ↦ᵣ updatePcPerm wadv (* The specification stops after the jump *)
                ∗ r_t1 ↦ᵣ WCap p_mem (b_mem^+(secret_off+1))%a e_mem secret%a
                ∗ r_t2 ↦ᵣ WInt (b_mem+(secret_off +1))
                ∗ r_t3 ↦ᵣ WInt e_mem
                ∗ r_t30 ↦ᵣ wadv
                ∗ codefrag a_prog (prog_code secret_off secret_val)
                ∗ [[(secret ^+1)%a, e_mem]] ↦ₐ [[ region_addrs_zeroes (secret^+1)%a e_mem ]]
                -∗ WP Seq (Instr Executable) {{ φ }}))
        -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof.
    intros * Hpc_perm Hpc_bounds Hlen_mem Hp_mem.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr30& Hr2& Hr3& Post)".
    rewrite /prog_code.
    codefrag_facts "Hprog".
    focus_block_0 "Hprog" as "Hprog" "Hcont".
    (* 1 - Specification from Lea to Subsug *)
    iApply (prog_base_spec with "[-]")
    ; try (iFrame ; iFrame "#")
    ; eauto
    ; try solve_addr'.
    iNext ; iIntros "(HPC & Hr1 & Hr2 & Hr3 & Hmem & Hsecret & Hmem' & Hprog)".
    unfocus_block "Hprog" "Hcont" as "Hprog".

    (* 2 - Jump to the adversary *)
    (* jmp *)
    iInstr "Hprog".
    (* 3 - Post condition *)
    iApply "Post".
    subst secret.
    replace ((b_mem ^+ secret_off) ^+ 1)%a with (b_mem ^+ (secret_off+1))%a by solve_addr.
    replace  (b_mem + secret_off + 1)%Z with (b_mem + (secret_off + 1))%Z by lia.
    iFrame.
  Qed.

  Context {nainv: logrel_na_invs Σ}.

  (** Assuming that the word of the adversary is safe to share,
     the machine executes safely and completely.
     The assumption makes sense, because we consider adversary programs containing
     no capabilities. *)
  Lemma prog_spec_CPS_full
        p_pc b_pc e_pc a_prog (* pc *)
        p_mem b_mem e_mem (* mem *)
        w_adv
        secret_off secret_val
        rmap :

    let secret := (b_mem^+secret_off)%a in
    let len_p := (a_prog ^+ length (prog_code secret_off secret_val))%a in

      (* Validity PC*)
      ExecPCPerm p_pc ->
      SubBounds b_pc e_pc a_prog len_p ->

      (* Validity buffer *)
      (b_mem <= secret < e_mem)%a ->
      writeAllowed p_mem = true ->

      (* Register map for the big_sep of registers *)
      dom rmap = all_registers_s ∖ {[ PC; r_t1; r_t30 ]} →

      ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
          ∗ r_t1 ↦ᵣ WCap p_mem b_mem e_mem b_mem
          ∗ r_t30 ↦ᵣ w_adv
          ∗ codefrag a_prog (prog_code secret_off secret_val)
          ∗ [[b_mem, e_mem]] ↦ₐ [[ region_addrs_zeroes b_mem e_mem ]]
          (* All the registers contains integers *)
          ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝)
          (* The NA token is required for the post condition *)
          ∗ na_own logrel_nais ⊤
          (* The adversary word is safe to share *)
          ∗ interp w_adv
          (* Post condition of the corollary of the FTLR *)
          -∗ WP Seq (Instr Executable)
                {{ v, ⌜v = HaltedV⌝ → (* if the machine halts *)
                     (* we own all the registers *)
                      ∃ r : Reg, full_map r ∧ registers_mapsto r
                      (* all the NA invariants are closed*)
                      ∗ na_own logrel_nais ⊤}})%I.

  Proof.
    intros * Hpc_perm Hpc_bounds Hvsecret Hp_mem Hrmap_dom.
    iIntros "(HPC & Hr1 & Hr30 & Hprog & Hregion & Hrmap & Hna & #Hadv)".

    (* Using the FLTR corollary, w_adv is safe to execute and we can specify
       what happens after the jump: safe and complete execution *)
    (* It is required to do it _before_ the specification, because it introduces a
       later modality *)
    iDestruct (jmp_to_unknown with "Hadv") as "Cont".

    (* 1 - Specification of the known program *)
    (* Extract the register r_t2 and r_t3, required for `prog_spec_CPS` *)

    iExtractList "Hrmap" [r_t2;r_t3] as ["[Hr2 _]";"[Hr3 _]"].
    (* extract_register r_t2 with "Hrmap" as (w2 Hw2) "[[Hr2 _] Hrmap]". *)
    (* extract_register r_t3 with "Hrmap" as (w3 Hw3) "[[Hr3 _] Hrmap]". *)

    iApply (prog_spec_CPS with "[-]") ; try eassumption.
    iFrame "HPC Hr1 Hr30 Hregion Hr2 Hr3 Hprog".
    iNext ; iIntros "(HPC& Hr1& Hr2& Hr3 & Hr30 & Hprog & Hmem)".

    (* 2 - The continuation requires all the registers to be safe to share *)
    (* Show that the contents of r1 are safe *)
    replace ((b_mem ^+ secret_off) ^+ 1)%a
      with (b_mem ^+ (secret_off+1))%a by (subst secret ; by solve_addr).
    rewrite /region_mapsto.
    iDestruct (region_integers_alloc' _ _ _ (b_mem ^+ secret_off)%a _ p_mem with "Hmem")
      as ">#Hmem_safe".
    { rewrite /region_addrs_zeroes. apply Forall_replicate. auto. }

    (* put the other registers back into the register map *)

    iAssert ( ⌜is_z (WInt (b_mem + (secret_off + 1))) = true ⌝)%I as "Hvr2". auto.
    iCombine "Hr2 Hvr2" as "Hr2".
    iAssert ( ⌜is_z (WInt e_mem) = true ⌝)%I as "Hvr3". auto.
    iCombine "Hr3 Hvr3" as "Hr3".
    iInsertList "Hrmap" [r_t3;r_t2]. iClear "Hvr2 Hvr3".

    (* Show that the contents of unused registers is safe *)
    set (rmap' :=  <[r_t2:=WInt _]> (<[r_t3:= _]> rmap)).
    iAssert ([∗ map] r↦w ∈ rmap', r ↦ᵣ w ∗ interp w)%I with "[Hrmap]" as "Hrmap".
    { subst rmap'.
      iApply (big_sepM_mono with "Hrmap"). intros r w Hr'. cbn. iIntros "[? %Hw]". iFrame.
      destruct_word w; try by inversion Hw. rewrite fixpoint_interp1_eq //. }

    (* put the registers with capability back into the register map *)
    iCombine "Hr1 Hmem_safe" as "Hr1".
    iCombine "Hr30 Hadv" as "Hr30".
    subst rmap'; iInsertList "Hrmap" [r_t1;r_t30].

    (* 3 - Use the continuation *)

    (* Prepare the resources *)
    iApply "Cont" ; eauto. 2 : iFrame.
    iPureIntro. subst.
    { do 2 (rewrite dom_insert_L).
      assert (all_registers_s ∖ {[PC]} =
                ({[r_t1; r_t30]} ∪ all_registers_s ∖ {[PC; r_t1; r_t30]})) as ->.
      { rewrite - !difference_difference_L.
        assert ( all_registers_s ∖ {[PC]} ∖ {[r_t1]} ∖ {[r_t30]} =
                   all_registers_s ∖ {[PC]} ∖ {[r_t1; r_t30]})
          as -> by (rewrite - !difference_difference_L ; set_solver).
        rewrite -union_difference_L; auto.
        apply subseteq_difference_r;[set_solver|].
        apply all_registers_subseteq. }
      set_solver. }

    (* Alternative for (3) *)
    (* iApply (wp_wand with "[-]"). *)
    (* { iApply "Cont"; cycle 1. iFrame. iPureIntro. rewrite !dom_insert_L Hrmap_dom. *)
    (*   rewrite !singleton_union_difference_L. set_solver+. } *)
    (* iIntros (?) "?" ; done. *)
  Qed.

(** The encapsulation of the program is safe-to-share
    By unfolding the definition of V(E,-,-,-) , we can use only persistent
    proposition. Thus, all the required resources of the memory have to be
    encapsulated in invariants. *)

  Definition N : namespace := nroot .@ "secret".
  Definition start_memN := (N.@"start_mem").
  Definition secretN := (N.@"secret").
  Definition end_memN := (N.@"end_mem").
  Definition codeN := (N.@"code").

  (* The first part of the buffer, before the secret, is always zeroes *)
  Definition start_mem_inv (b_mem e_mem : Addr) secret_off:=
    let secret_addr := (b_mem ^+ secret_off)%a in
    na_inv logrel_nais start_memN
           ([[b_mem, secret_addr]] ↦ₐ [[ region_addrs_zeroes b_mem secret_addr ]]).

  (* The secret is either equal to 0 -- at the initialisation -- or equal to
     42 -- after the secret was stored *)
  Definition secret_inv (b_mem : Addr) secret_off secret :=
    let secret_addr := (b_mem ^+ secret_off)%a in
    na_inv logrel_nais secretN
           ((secret_addr ↦ₐ WInt 0) ∨ (secret_addr ↦ₐ WInt secret)).

  (* The code instruction is stored in an invariant as well *)
  Definition code_inv a_prog secret_off secret :=
    na_inv logrel_nais codeN (codefrag a_prog (prog_code secret_off secret)).

  Definition end_mem_inv b_mem e_mem secret_off :=
    let n_secret_addr := (b_mem ^+ (secret_off +1))%a in
    na_inv logrel_nais end_memN
           ([∗ list] a ∈ finz.seq_between n_secret_addr e_mem,
            ∃ P, inv (logN .@ a) (interp_ref_inv a P) ∗ read_cond P interp
                                                          ∗ write_cond P interp)%I.

  (** Currently, we cannot prove the closure, because we need more information
      about the buffer. Since the closure means "called in any context",
      we cannot assume that the buffer is correctly set up in the context,
      i.e. we cannot assume that the register r1 contains the capability
      pointing to the buffer.

      In order to get the right context, we may change our code. Here is 2
      solutions:
      - we assume that our program contains a capability pointing to our buffer,
        we need to load the capability in R1 before our program. It corresponds
        to a closure around the code and the buffer
      - we dynamically allocate the buffer, by using the `malloc` macro.
        It is different from the previous solution, because it allocates a new
        buffer each time our program is called

   *)
  Lemma prog_CPS_safe_to_share b_pc e_pc a_prog b_mem e_mem secret_off secret :

    (* The instructions of the code are in the memory closure of the PCC *)
    SubBounds b_pc e_pc a_prog (a_prog ^+ length (prog_code secret_off secret))% a ->
    (* The secret offset fits in the memory buffer *)
    (b_mem <= b_mem ^+ secret_off < e_mem)%a ->

    ⊢ ( code_inv a_prog secret_off secret
       ∗ start_mem_inv b_mem e_mem secret_off
       ∗ end_mem_inv b_mem e_mem secret_off
       ∗ secret_inv b_mem secret_off secret)

   -∗ interp (WCap E b_pc e_pc a_prog).
  Abort.

End base_program_CPS.


(**
  This file contains an implementation of the example token that complies with the Concordium's CIS1 standard.
  The development is inspired by the Rust implementation: https://github.com/Concordium/concordium-rust-smart-contracts/blob/b49a9f07131b2659de2f7b55eb5e8365d0ed4720/examples/cis1-wccd/src/lib.rs

  We also show that the implementation of the token complies with our formalization of the CIS1 standard.
*)

From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import Logic.Eqdep_dec.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Examples.CIS1 Require Import CIS1Spec.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Utils Require Import Extras.

Import ListNotations.

Definition requireTrue (cond : bool) :=
  if cond then Some tt else None.

Section WccdToken.
  Context {BaseTypes : ChainBase}.
  Set Nonrecursive Elimination Schemes.

  (** Similarly to the Concordium implementation we use the smallest token id type, because
      the contract hold tokens of only one type *)
  Definition TokenID := unit.

  Open Scope bool.

  (** * Entry points *)

  Record wccd_transfer_params :=
    { wccd_td_token_id : TokenID;
      wccd_td_amount   : TokenAmount;
      wccd_td_from     : Address;
      wccd_td_to       : Address }.

  Inductive OpUpdateKind :=
  | opAdd
  | opDelete.

  Inductive Msg :=
  | wccd_msg_transfer (params : list wccd_transfer_params)
  | wccd_msg_balanceOf (query : list Address) (send_results_to : Address)
  | wccd_msg_updateOperator (params : list (OpUpdateKind * Address))
  | wccd_msg_mint (receiver : Address)
  | wccd_msg_burn (amount : TokenAmount).

  (** * Contract's state *)

  (** The state tracked for each address.*)
  Record AddressState := {
      wccd_balance   : TokenAmount;
      wccd_operators : list Address
    }.

  (* begin hide *)
  MetaCoq Run (make_setters AddressState).
  (* end hide *)

  (** The contract state: a mapping from addresses to [AddressState] *)

  Definition State := AddressMap.AddrMap AddressState.

  Section Serialization.

    Global Instance OpUpdateKind_serializable : Serializable OpUpdateKind :=
      Derive Serializable OpUpdateKind_rect <opAdd, opDelete>.

    Global Instance state_serializable : Serializable AddressState :=
      Derive Serializable AddressState_rect <Build_AddressState>.

    Global Instance wccd_transfer_params_serializable : Serializable wccd_transfer_params :=
      Derive Serializable wccd_transfer_params_rect <Build_wccd_transfer_params>.

    Global Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <wccd_msg_transfer, wccd_msg_balanceOf, wccd_msg_updateOperator, wccd_msg_mint, wccd_msg_burn>.

  End Serialization.

  (** * Transfer *)

  Definition increment_balance (st : State) (addr : Address) (inc : TokenAmount) : State :=
    match AddressMap.find addr st with
    | Some old => AddressMap.add addr (old<| wccd_balance := old.(wccd_balance) + inc |>) st
    | None => AddressMap.add addr {| wccd_balance := inc ; wccd_operators := [] |} st
    end.

  Definition decrement_balance (st : State) (addr : Address) (dec : TokenAmount) : option State :=
    do old <- AddressMap.find addr st;
    let old_balance := old.(wccd_balance) in
    do requireTrue (dec <=? old_balance);
    ret (AddressMap.add addr (old<| wccd_balance := old_balance - dec |>) st).

  Definition is_operator (addr owner : Address)(st : State) : bool :=
    match AddressMap.find owner st with
    | Some v => existsb (fun x => (addr =? x)%address) v.(wccd_operators)
    | None => false
    end.

  (** Single transfer of [amount] between [from] and [to] *)
  Definition wccd_transfer_single
             (token_id : TokenID)
             (amount : TokenAmount)
             (owner from to : Address)
             (prev_st : State) : option State :=
    do requireTrue ((owner =? from)%address || is_operator from owner prev_st);
    do st <- decrement_balance prev_st from amount;
    ret (increment_balance st to amount).

  (** Batch execution of all transfers in the list. Note that the
      operation succeeds only if all transfers in the batch succeed *)
  Definition wccd_transfer (ctx : ContractCallContext) (transfers : list wccd_transfer_params) (prev_st : State)
    : option State :=
    monad_foldl (fun acc x =>
                   let owner := ctx.(ctx_from) in
                   wccd_transfer_single tt x.(wccd_td_amount) owner x.(wccd_td_from) x.(wccd_td_to) acc)
                prev_st transfers.

  (** * balanceOf *)

  Definition get_balance_opt (addr : Address) (st : State) : option TokenAmount :=
    match AddressMap.find addr st with
    | Some data => Some data.(wccd_balance)
    | None => None
    end.

  Definition wccd_balanceOf (query : list Address) (st : State)
    : list (TokenID * Address * TokenAmount) :=
    map (fun addr => (tt, addr, with_default 0 (get_balance_opt addr st))) query.

  (** * updateOperator *)

  Definition add_remove (operators : list Address) (param : OpUpdateKind * Address) :=
    let '(updateKind,addr) := param in
    match updateKind with
    | opAdd => addr :: operators
    | opDelete => remove address_eqdec addr operators
    end.

  (** NOTE: in contrast to the Concordium's implementation, we do not
      allow adding operators to non-existing addresses *)
  Definition wccd_updateOperator (owner : Address) (params : list (OpUpdateKind * Address)) (prev_st : State)
    : option State :=
    do owner_data <- AddressMap.find owner prev_st;
    let updated_owner_data := owner_data<| wccd_operators := fold_left add_remove params owner_data.(wccd_operators) |> in
    ret (AddressMap.add owner updated_owner_data prev_st).

  (** * WCCD receive *)

  (** We dispatch on a message of type [Msg] and call the corresponding functions with received parameters *)
  Definition wccd_receive
             (chain : Chain)
             (ctx : ContractCallContext)
             (prev_st : State)
             (msg : option Msg)
    : option (State * list ActionBody) :=
    match msg with
    | Some (wccd_msg_transfer params) =>
        do next_st <- wccd_transfer ctx params prev_st;
        let contract_accounts :=
          filter (fun x => address_is_contract x.(wccd_td_to)) params in
        let mk_callback x :=
        (* NOTE: we assume that the receiving contract accepts messages of type
           (TokenID * TokenAmount * Address) *)
          act_call x.(wccd_td_to) 0 (serialize (tt,x.(wccd_td_amount), x.(wccd_td_from))) in
        let ops := map mk_callback contract_accounts in
        ret (next_st, ops)
    | Some (wccd_msg_balanceOf query send_to) =>
        let balances := wccd_balanceOf query prev_st in
        do requireTrue (address_is_contract send_to);
        ret (prev_st, [act_call send_to 0 (serialize balances)])
    | Some (wccd_msg_updateOperator params) =>
        do next_st <- wccd_updateOperator ctx.(ctx_from) params prev_st;
        ret (next_st, [])
    | Some (wccd_msg_mint receiver) =>
        (* Check that the sender is not the receiver *)
        do requireTrue (address_neqb receiver ctx.(ctx_from));
        let next_st := increment_balance prev_st receiver (Z.to_nat ctx.(ctx_amount)) in
        (* NOTE: we only update the state and do not notify the receiver *)
        ret (next_st,[])
    | Some (wccd_msg_burn amt) =>
        (* Check that the sender is not the receiver *)
        do next_st <- decrement_balance prev_st ctx.(ctx_from) amt;
        ret (next_st, [act_transfer ctx.(ctx_from) (Z.of_nat amt)])
    | None => None
    end.

End WccdToken.

(** * WCCD complies with CIS1 *)

Module WccdTypes <: CIS1Types.

  Definition Msg `{ChainBase} := Msg.

  Definition Storage `{ChainBase} := State.

  Definition TokenID := TokenID.

  Definition serializable_token_id : Serializable TokenID := _.

  Definition token_id_eqb (id1 id2 : TokenID) := true.

  Lemma token_id_eqb_spec :
    forall (a b : TokenID), Bool.reflect (a = b) (token_id_eqb a b).
  Proof. intros. constructor. now destruct a,b. Qed.

End WccdTypes.

Module WccdView <: CIS1View WccdTypes.

  Import WccdTypes.

  Section WccdViewDefs.

    Context `{ChainBase}.

    Definition get_balance_opt st (token_id : TokenID) addr :=
      get_balance_opt addr st.

    Definition get_operators (st : Storage) (addr : Address) :=
      match AddressMap.find addr st with
      | Some v => v.(wccd_operators)
      | None => []
      end.

    Definition get_owners : Storage -> TokenID -> list Address :=
      fun st token_id => FMap.keys st.

    Lemma get_owners_no_dup : forall st token_id, NoDup (get_owners st token_id).
    Proof.
      intros. unfold get_owners; apply FMap.NoDup_keys.
    Qed.

    Lemma In_keys_In_elements_iff {K V : Type} `{countable.Countable K} (m : FMap K V) (k : K) :
      In k (FMap.keys m) <-> exists v, In (k,v) (FMap.elements m).
    Proof.
      split.
      - induction m using fin_maps.map_ind; intros Hin.
        + easy.
        + unfold FMap.keys in *.
          rewrite FMap.elements_add in Hin by assumption.
          cbn in *. destruct Hin.
          * exists x. rewrite FMap.elements_add by assumption. now left.
          * destruct (IHm H2) as [x0 Hx0]. exists x0.
            rewrite FMap.elements_add by assumption.
            now right.
      - induction m using fin_maps.map_ind; intros Hex.
        + now destruct Hex.
        + destruct Hex as [v Hv].
          unfold FMap.keys.
          rewrite FMap.elements_add in * by assumption; cbn in *.
          destruct Hv as [HH | HH]; try inversion HH; easy.
    Qed.

    Lemma get_owners_balances : forall st owner token_id,
        In owner (get_owners st token_id) <->
          exists balance, get_balance_opt st token_id owner = Some balance.
    Proof.
      split.
      + intros Hin. unfold get_owners in *.
        unfold get_balance_opt,Cis1wccd.get_balance_opt.
        apply In_keys_In_elements_iff in Hin.
        destruct Hin as [a_st HH].
        exists a_st.(wccd_balance).
        apply FMap.In_elements in HH.
        unfold AddressMap.find,FMap.find in *.
        now rewrite HH.
      + intros Hex.
        destruct Hex as [b Hb].
        unfold get_owners, FMap.keys.
        unfold get_balance_opt,Cis1wccd.get_balance_opt in *.
        destruct (AddressMap.find owner st) eqn:Heq; try congruence.
        unfold AddressMap.find in *.
        apply FMap.In_elements in Heq.
        apply In_keys_In_elements_iff.
        eauto.
    Qed.

    Definition token_id_exists (st : Storage) (token_id : TokenID) : bool := true.

  End WccdViewDefs.
End WccdView.

Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView.

  Module cis1_axioms := CIS1Axioms WccdTypes WccdView.
  Import cis1_axioms.

  Module BalancesFacts := CIS1Balances WccdTypes WccdView.
  Import BalancesFacts.

  Section WccdReceiveDefs.

    Context `{ChainBase}.

    (** Converting _to_ the CIS1 standard parameters *)
    Definition to_cis1_transfer_data (p : wccd_transfer_params) : CIS1_transfer_data :=
      let '(Build_wccd_transfer_params token_id amt from_addr to_addr) := p in
      {| cis1_td_token_id := token_id;
         cis1_td_amount := amt;
         cis1_td_from := from_addr;
         cis1_td_to := to_addr |}.

    Definition to_cis1_updateOperator_kind (op : OpUpdateKind) : CIS1_updateOperator_kind :=
      match op with
      | opAdd => cis1_ou_add_operator
      | opDelete => cis1_ou_remove_operator
      end.

    Definition to_cis1_balanceOf_params (query : list Address) (send_to : Address)
      : option CIS1_balanceOf_params :=
      match Bool.bool_dec (address_is_contract send_to) true with
      | left p =>
          Some {|cis1_bo_query := map (fun addr => Build_CIS1_balanceOf_query _ tt addr) query;
                 cis1_bo_result_address := send_to;
                 cis1_bo_result_address_is_contract := p |}
      | right _ => None
      end.

    Definition get_CIS1_entry_point : Msg -> option CIS1_entry_points :=
      fun msg => match msg with
              | wccd_msg_transfer params =>
                  let params :=
                    {| cis_tr_transfers := map to_cis1_transfer_data params|} in
                  Some (CIS1_transfer params)
              | wccd_msg_balanceOf query send_results_to =>
                  do p <- to_cis1_balanceOf_params query send_results_to;
                  Some (CIS1_balanceOf p)
              | wccd_msg_updateOperator params =>
                  let upd_list :=
                    map (fun '(upd_kind, addr) =>
                           Build_CIS1_updateOperator_update _ (to_cis1_updateOperator_kind upd_kind) addr) params in
                  Some (CIS1_updateOperator {| cis1_ou_params := upd_list |})
              | wccd_msg_mint receiver => None
              | wccd_msg_burn amount => None
              end.

    (** Converting _from_ the CIS1 standard parameters *)

    Definition from_cis1_transfer_data (p : CIS1_transfer_data) : wccd_transfer_params :=
      let '(Build_CIS1_transfer_data _ token_id amt from_addr to_addr) := p in
      {| wccd_td_token_id := tt;
         wccd_td_amount := amt;
         wccd_td_from := from_addr;
         wccd_td_to := to_addr |}.

    Definition from_cis1_updateOperator_kind (op : CIS1_updateOperator_kind) : OpUpdateKind :=
      match op with
      | cis1_ou_remove_operator => opDelete
      | cis1_ou_add_operator => opAdd
      end.

    Definition from_cis1_balanceOf_params (query : CIS1_balanceOf_params) : list Address :=
      map cis1_bo_query_address query.(cis1_bo_query).

    Definition get_contract_msg : CIS1_entry_points -> Msg :=
      fun ep => match ep with
             | CIS1_transfer params =>
                 wccd_msg_transfer (map from_cis1_transfer_data params.(cis_tr_transfers))
             | CIS1_updateOperator params =>
                 let p := map (fun p => (from_cis1_updateOperator_kind p.(cis1_ou_update_kind), p.(cis1_ou_operator_address))) params.(cis1_ou_params) in
                 wccd_msg_updateOperator p
             | CIS1_balanceOf params =>
                 wccd_msg_balanceOf (from_cis1_balanceOf_params params)
                                    params.(cis1_bo_result_address)
             end.

    Lemma left_inverse_get_CIS1_entry_point (entry_point : CIS1_entry_points) :
      get_CIS1_entry_point (get_contract_msg entry_point) = Some entry_point.
    Proof.
      destruct entry_point; cbn.
      + destruct params as [xs]. repeat f_equal.
        induction xs; auto.
        cbn. destruct a as [tid ? ?]; cbn in *. destruct tid. repeat f_equal; auto.
      + destruct params as [xs]. repeat f_equal.
        rewrite map_map.
        induction xs; auto.
        destruct a as [ok ?]; cbn in *. destruct ok; repeat f_equal; auto.
      + destruct params as [xs send_to p]; cbn in *.
        unfold to_cis1_balanceOf_params.
        destruct (Bool.bool_dec (address_is_contract send_to) true) eqn:Heq; repeat f_equal.
        * induction xs; cbn in *; auto.
          destruct a as [tid ?]; destruct tid; cbn; now repeat f_equal.
        * apply UIP_dec. apply Bool.bool_dec.
        * congruence.
    Qed.

    Lemma inctement_balance_find_ne st addr1 addr2 amt :
      addr1 <> addr2 ->
      AddressMap.find addr1 (increment_balance st addr2 amt) = AddressMap.find addr1 st.
    Proof.
      intros Hneq.
      unfold increment_balance.
      destruct (AddressMap.find addr2 _);
        unfold AddressMap.add, AddressMap.find;
        now rewrite fin_maps.lookup_insert_ne.
    Qed.

    Import Lia.

    Lemma wccd_transfer_single_cis1 (token_id : TokenID)
          (amt : TokenAmount) (owner_addr from_addr to_addr : Address)
          (prev_st st : State) :
      wccd_transfer_single token_id amt owner_addr from_addr to_addr prev_st = Some st ->
      transfer_single_spec prev_st st token_id eq_refl eq_refl owner_addr from_addr to_addr amt.
    Proof.
      intros Haddr.
      cbn in *.
      destruct (requireTrue (_ || _)) eqn:Hpermissions; try congruence.
      destruct (AddressMap.find _ _) as [v |] eqn:Hv; try congruence.
      destruct (requireTrue (_ <=? _)) eqn:Hbalance; try congruence.
      inversion Haddr; subst; clear Haddr.
      destruct (amt <=? wccd_balance v) eqn:Hamt; cbn in *; try congruence.
      apply leb_complete in Hamt.
      repeat split; cbn.
      + intros.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        unfold WccdView.get_balance_opt, get_balance_opt.
        rewrite inctement_balance_find_ne by assumption.
        unfold AddressMap.find,AddressMap.add.
        now erewrite fin_maps.lookup_insert_ne.
      + intros. now destruct other_token_id,token_id.
      + unfold requireTrue in *. destruct (orb _ _) eqn:Hp; try congruence.
        rewrite Bool.orb_true_iff in *.
        destruct Hp as [Hp | Hp].
        * now destruct (address_eqb_spec owner_addr from_addr).
        * right.
          unfold is_operator in *.
          unfold WccdView.get_operators.
          destruct (AddressMap.find owner_addr prev_st) eqn:Hfind; try congruence.
          apply existsb_exists in Hp.
          destruct Hp as [addr0 [Hin Heq]].
          now destruct (address_eqb_spec from_addr addr0).
      + repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        destruct (AddressMap.find to_addr _) eqn:Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite Hv.
          rewrite FMap.add_commute with (m := prev_st) by auto.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          lia.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.add_commute with (m := prev_st) by auto.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)).
          cbn. rewrite Hv.
          lia.
      + repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        destruct (AddressMap.find to_addr _) eqn:Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto.
          unfold FMap.find in *.
          now rewrite Haddr.
        * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *.
          rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn.
          rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto.
          unfold FMap.find in *.
          now rewrite Haddr.
      + subst. repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance.
        unfold WccdView.get_balance_opt,get_balance_opt. now rewrite Hv.
      + subst.
        repeat rewrite get_balance_total_get_balance_default.
        repeat unfold setter_from_getter_AddressState_wccd_balance,
          set_AddressState_wccd_balance,increment_balance.
        unfold get_balance_default,cis1_axioms.VExtra.get_balance in *. cbn.
        unfold WccdView.get_balance_opt,get_balance_opt.
        rewrite Hv.
        unfold AddressMap.find,AddressMap.add.
        rewrite FMap.find_add with (m := prev_st); cbn.
        rewrite FMap.find_add with (m := FMap.add _ _ prev_st); cbn.
        lia.
    Qed.

    Definition contract_receive := wccd_receive.

    Lemma get_balances_wccd_balanceOf next_st c query send_results_to :
      to_cis1_balanceOf_params query send_results_to = Some c ->
      get_balances next_st c = Some (wccd_balanceOf query next_st).
    Proof.
      intros Hparams.
      unfold to_cis1_balanceOf_params in *.
      destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:Haddr;
        inversion Hparams; subst; clear Hparams.
      cbn.
      revert dependent next_st.
      revert dependent send_results_to.
      induction query.
      - now intros ? ? ? Hparams; cbn in *.
      - intros. cbn.
        erewrite IHquery; eauto.
        unfold WccdView.get_balance_opt.
        now destruct (get_balance_opt _ _).
    Qed.

    (** ** Receive specification *)
    Theorem receive_spec :
    forall (chain : Chain)
      (ctx : ContractCallContext)
      (entry : CIS1_entry_points)
      (msg : Msg)
      (prev_st next_st : State)
      (ops : list ActionBody),
      get_CIS1_entry_point msg = Some entry ->
      wccd_receive chain ctx prev_st (Some msg) = Some (next_st, ops) ->
      match entry with
      | CIS1_transfer params => transfer_spec ctx params prev_st next_st ops
      | CIS1_updateOperator params => updateOperator_spec ctx params prev_st next_st ops
      | CIS1_balanceOf params => balanceOf_spec params prev_st next_st ops
      end.
    Proof.
      intros ? ? ? ? ? ? ? Hep Hreceive.
      destruct msg; cbn; inversion Hep as [HH]; subst; clear Hep; try easy.
      + simpl in *.
        destruct (wccd_transfer _ _) eqn:Htr; try congruence.
        inversion Hreceive; subst; clear Hreceive.
        constructor.
        * cbn.
          revert dependent next_st.
          revert dependent prev_st.
          induction params.
          ** cbn in *. congruence.
          ** intros prev_st next_st Hreceive.
             cbn -[wccd_transfer_single] in *.
             destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence.
             destruct a as [tid amt from_addr to_addr]; cbn.
             simpl in *.
             exists st, eq_refl, eq_refl.
             split.
             *** cbn in *. now apply wccd_transfer_single_cis1.
             *** now eapply IHparams.
        * cbn.
          revert dependent prev_st.
          revert dependent next_st.
          induction params.
          ** intros; cbn; auto.
          ** intros; cbn -[wccd_transfer_single] in *.
             destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence.
             destruct a as [token_id amt addr]; cbn.
             destruct (address_is_contract _).
             *** constructor; simpl in *.
                 eexists. split.
                 **** reflexivity.
                 **** destruct token_id.
                      exists (TokenID * TokenAmount * Address)%type. exists _. exists id.
                      eexists. split.
                      apply deserialize_serialize.
                      reflexivity.
                 **** eapply IHparams; eauto.
             *** eapply IHparams; eauto.
      + simpl in *.
        destruct (address_is_contract send_results_to) eqn:Haddr;
          inversion Hreceive; subst; clear Hreceive; cbn in *.
        destruct (to_cis1_balanceOf_params _ _) eqn:Hto_cis1; inversion HH; subst; clear HH.
        constructor; subst; auto.
        erewrite get_balances_wccd_balanceOf; eauto.
        cbn. repeat f_equal.
        unfold to_cis1_balanceOf_params in *.
        destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:HH;
          now inversion Hto_cis1.
      + cbn in *.
        unfold setter_from_getter_AddressState_wccd_operators,set_AddressState_wccd_operators in *.
        constructor; intros; cbn in *; auto.
        * unfold WccdView.get_balance_opt,get_balance_opt.
          destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive.
          destruct (address_eqb_spec addr ctx.(ctx_from)).
          ** subst.
             rewrite Haddr.
             unfold AddressMap.find,AddressMap.add.
             now rewrite FMap.find_add with (m := prev_st).
          ** unfold AddressMap.find,AddressMap.add.
             now rewrite fin_maps.lookup_insert_ne.
        * destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive.
          destruct a as [bal ops]; cbn in *.
          revert dependent ops.
          revert dependent prev_st.
          induction params; intros prev_st ops Haddr.
          ** cbn.
             unfold AddressMap.add,AddressMap.find in *.
             now symmetry; apply FMap.add_id.
          ** cbn.
             unfold AddressMap.add,AddressMap.find in *.
             destruct a as [ok oaddr]; cbn in *.
             unfold updateOperator_single_spec; cbn.
             destruct ok; cbn in *.
             *** set (st := FMap.add (ctx_from ctx)
                                     {| wccd_balance := bal;
                                       wccd_operators := oaddr :: ops |} prev_st).
                 exists st. split.
                 **** split.
                      ***** intros.
                      subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite Haddr. rewrite FMap.find_add with (m := prev_st).
                      cbn.
                      split; intros; auto. destruct H1; subst; congruence.
                      ***** subst st. unfold WccdView.get_operators,AddressMap.find.
                      now rewrite FMap.find_add with (m := prev_st); cbn.
                 **** set (ops' := oaddr :: ops).
                      specialize (IHparams st ops'). subst ops' st; cbn in *.
                      repeat rewrite FMap.add_add with (m := prev_st)in IHparams.
                      apply IHparams.
                      now rewrite FMap.find_add with (m := prev_st).
             *** set (st := FMap.add (ctx_from ctx)
                                     {| wccd_balance := bal;
                                        wccd_operators := remove address_eqdec oaddr ops |} prev_st).
                 exists st. split.
                 **** split.
                      (* the cases are essentially just properties of [remove], which we
                         prove using the [hint] database *)
                      ***** intros.
                      subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite Haddr. rewrite FMap.find_add with (m := prev_st).
                      cbn.
                      split; intros; eauto with hints.
                      ***** subst st. unfold WccdView.get_operators,AddressMap.find.
                      rewrite FMap.find_add with (m := prev_st); cbn; auto with hints.
                 **** set (ops' := remove address_eqdec oaddr ops).
                      specialize (IHparams st ops'). subst ops' st; cbn in *.
                      repeat rewrite FMap.add_add with (m := prev_st)in IHparams.
                      apply IHparams.
                      now rewrite FMap.find_add with (m := prev_st).
    Qed.
  End WccdReceiveDefs.
End WccdReceiveSpec.