(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** * Replacement (Introduction-qp) Typing *)

(** This module contains lemmas related to replacement typing
    ([|-//] and [|-//v]). *)

Set Implicit Arguments.

Require Import Coq.Program.Equality List String.
Require Import Sequences.
Require Import Definitions Binding InvertibleTyping Narrowing PreciseTyping
        RecordAndInertTypes Replacement Subenvironments TightTyping Weakening.

(** Whereas invertible typing does replacement for singleton types in one direction,
    replacement typing does the replacment in the other direction.

    Note that we can't simply define this using three rules:
    1) identity from invertible typing
    2) two repl subtyping rules
    The reason is that if we did that, repl typing would necessarily apply the replacement
    in all subterms of a term, whereas we want to be able to say, for example:
    [Г ⊢## p: T] #
#
    [Г ⊢// p: U] #
#
    [__________] #
#
    [Г ⊢// p: T ∧ U] #
#
 *)

(** ** Replacement Typing for Paths *)

Reserved Notation "G '⊢//' p ':' T" (at level 40, p at level 59).

Inductive ty_repl : ctx -> path -> typ -> Prop :=

(** [G ⊢## p: T]     #
#
    [―――――――――――――――] #
#
    [G ⊢// p: T]     *)
| ty_inv_r : forall G p T,
    G ⊢## p: T ->
    G ⊢// p: T

(** [G ⊢// p : T]     #
#
    [G ⊢// p : U]     #
#
    [――――――――――――――――] #
#
    [G ⊢// p : T /\ U]      *)
| ty_and_r : forall G p T U,
    G ⊢// p: T ->
    G ⊢// p: U ->
    G ⊢// p: T ∧ U

(** [G ⊢## p : T^p]  #
#
    [――――――――――――――] #
#
    [G ⊢## p : μ(T)]      *)
| ty_bnd_r : forall G p T,
    G ⊢// p: open_typ_p p T ->
    G ⊢// p: μ T

(** [G ⊢// p : T]             #
#
    [G ⊢! q: _ ⪼ {A: T..T}]  #
#
    [―――――――――――――――――――――――] #
#
    [G ⊢//p : q.A]      *)
| ty_sel_r : forall G p T q S A,
    G ⊢// p: T ->
    G ⊢! q: S ⪼ typ_rcd {A >: T <: T} ->
    G ⊢// p: q↓A

(** [G ⊢// p.a: T]    #
#
    [―――――――――――――――] #
#
    [G ⊢// p: {a: T}]     *)
| ty_rcd_intro_r : forall G p a T,
    G ⊢// p•a : T ->
    G ⊢// p : typ_rcd { a ⦂ T }

(** [G ⊢! p: q.type ⪼ q.type]   #
#
    [G ⊢!! q]                   #
#
    [G ⊢// r: μ(T)]             #
#
    [――――――――――――――――――――]      #
#
    [G ⊢// p: μ(T[q/p])]      *)

| ty_rec_qp_r : forall G p q r T T' U,
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q : U ->
    G ⊢// r : μ T ->
    repl_typ q p T T' ->
    G ⊢// r : μ T'

(** [G ⊢! p: q.type ⪼ q.type]   #
#
    [G ⊢!! q]                   #
#
    [G ⊢// r: r'.A]             #
#x
    [――――――――――――――――――――]      #
#
    [G ⊢// p: (r'.A)[q/p]]      *)
| ty_sel_qp_r : forall G p q r A bs U,
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q: U ->
    G ⊢// r : (q •• bs)↓A ->
    G ⊢// r : (p •• bs)↓A

(** [G ⊢! p: q.type ⪼ q.type]   #
#
    [G ⊢!! q]                   #
#
    [G ⊢// r: r'.type]          #
#
    [――――――――――――――――――――]      #
#
    [G ⊢// p: (r'.type)[q/p]]      *)
| ty_sngl_qp_r : forall G p q r bs U,
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q: U ->
    G ⊢// r : {{ q •• bs }} ->
    G ⊢// r : {{ p •• bs }}

(** [G ⊢## p]   #
#
    [―――――――――――――] #
#
    [G ⊢## p: top]     *)
| ty_top_r : forall G p T,
  G ⊢// p : T ->
  G ⊢// p : ⊤

(** [G ⊢## p: {a: T}] #
#
    [G ⊢# T <: U]     #
#
    [――――――――――――――――] #
#
    [G ⊢## p: {a: U}]     *)

| ty_dec_trm_r : forall G p a T U,
  G ⊢// p : typ_rcd {a ⦂ T} ->
  G ⊢# T <: U ->
  G ⊢// p : typ_rcd {a ⦂ U}
(** [G ⊢## p: {A: T1..S1}]   #
#
    [G ⊢# T2 <: T1]         #
#
    [G ⊢# S1 <: S2]         #
#
    [―――――――――――――――――――――] #
#
    [G ⊢## p: {A: T2..S2}]     *)

| ty_dec_typ_r : forall G p A T1 T2 S1 S2,
  G ⊢// p : typ_rcd {A >: T1 <: S1} ->
  G ⊢# T2 <: T1 ->
  G ⊢# S1 <: S2 ->
  G ⊢// p : typ_rcd {A >: T2 <: S2}

(** [G ⊢## p: forall(S1)T1]          #
#
    [G ⊢# S2 <: S1]            #
#
    [G, y: S2 ⊢ T1^y <: T2^y]   #
#
    [y fresh]                  #
#
    [――――――――――――――――――――――]   #
#
    [G ⊢## p: forall(S')T']            *)
| ty_all_r : forall G T1 T2 S1 S2 L p,
  G ⊢// p : ∀(S1) T1 ->
  G ⊢# S2 <: S1 ->
  (forall y, y \notin L ->
   G & y ~ S2 ⊢ open_typ y T1 <: open_typ y T2) ->
  G ⊢// p : ∀(S2) T2

where "G '⊢//' p ':' T" := (ty_repl G p T).

Hint Constructors ty_repl.

(** *** From Replacement To Precise Typing *)

(** Replacement-to-precise typing for function types:
    if [G ⊢// p: forall(S)T] then
    - [exists S', T'. G ⊢!!! p: forall(S')T'],
    - [G ⊢# S <: S'], and
    - [G ⊢# T'^y <: T^y],
    where [y] is fresh. *)
Lemma repl_to_precise_typ_all: forall G p S T,
  inert G ->
  G ⊢// p : ∀(S) T ->
  exists S' T' L,
    G ⊢!!! p : ∀(S') T' /\
    G ⊢# S <: S' /\
    (forall y,
        y \notin L ->
            G & y ~ S ⊢ open_typ y T' <: open_typ y T).
Proof.
  introv Hi Hp. dependent induction Hp. apply* invertible_to_precise_typ_all.
  specialize (IHHp _ _ Hi eq_refl). destruct IHHp as [S' [T' [L' [Hp' [Hs1 Hs]]]]].
  exists  S' T' (L \u L' \u dom G). repeat split; auto. eauto.
  introv Hy. eapply subtyp_trans.
  + eapply narrow_subtyping. apply* Hs. apply subenv_last. apply* tight_to_general.
    apply* ok_push.
  + eauto.
Qed.

(** Replacement-to-precise typing for records:
    if [G |-// p: {A: S..U}] then
    - [exists T. G |-// p: {A: T..T}],
    - [G |-# T <: U], and
    - [G |-# S <: T] *)
Lemma repl_to_precise_rcd: forall G p A S U,
  inert G ->
  G ⊢// p : typ_rcd {A >: S <: U} ->
  exists T,
    G ⊢!!! p : typ_rcd {A >: T <: T} /\
    G ⊢# T <: U /\
    G ⊢# S <: T.
Proof.
  introv HG Hr. dependent induction Hr. apply* invertible_to_precise_rcd.
  specialize (IHHr _ _ _ HG eq_refl).
  destruct IHHr as [V [Hx [Hs1 Hs2]]]. exists V. split*.
Qed.

(** *** Properties of replacement typing *)

Lemma repl_and: forall G p T U,
    inert G ->
    G ⊢// p: T ∧ U ->
    G ⊢// p: T /\ G ⊢// p: U.
Proof.
  introv Hi Hp. dependent induction Hp; eauto.
  destruct (invertible_and Hi H). split*.
Qed.

(** Replacement typing is closed under [qp] replacement
    when we know [q]'s precise type *)
Lemma replacement_repl_closure_qp : forall G p q r T T' U,
    inert G ->
    G ⊢! q : {{ r }} ⪼ {{ r }} ->
    G ⊢!! r : U ->
    G ⊢// p : T ->
    repl_typ r q T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hq Hr Hp.
  gen q r T' U. induction Hp; introv Hq; introv Hr' Hr; try solve [invert_repl; eauto 5].
  - Case "ty_inv_r"%string.
    gen q r T' U. induction H; introv Hq; introv Hr; introv Hr'; try solve [invert_repl; eauto 5].
    -- SCase "ty_precise_inv"%string.
       destruct (pt3_inertsngl Hi H) as [[Hit | Hs] | Hst].
       + SSCase "ty_precise_inv_1"%string.
         inversions Hit; invert_repl.
         ++ eapply ty_all_r with (L := \{}).
            apply ty_inv_r.
            apply* ty_precise_inv. apply repl_swap in H5.
            eauto. introv Hy. auto.
         ++ eapply ty_all_r with (L := dom G).
            apply ty_inv_r.
            apply* ty_precise_inv. auto. introv Hy.
            eapply repl_open_var in H5; try solve_names.
            eapply subtyp_sngl_qp. apply* weaken_ty_trm.
            eapply precise_to_general. apply Hq. apply* weaken_ty_trm. apply* precise_to_general2. apply H5.
         ++ apply* ty_rec_qp_r.
       + SSCase "ty_precise_inv_2"%string.
         inversions Hs. invert_repl.
         eapply ty_sngl_qp_r; eauto.
       + SSCase "ty_precise_inv_3"%string.
         inversion Hst as [x Hx].
         generalize dependent T'.
         dependent induction Hx; introv Hr; subst; invert_repl.
         ++ destruct D2.
            * invert_repl. apply ty_precise_inv in H.
              assert (Hts : G ⊢# t0 <: T1).
              { apply repl_swap in H6. eauto. }
              eauto.
              invert_repl. apply ty_precise_inv in H.
              assert (Hts : G ⊢# T1 <: t1).
              { eauto. } eauto.
            * invert_repl. eapply ty_precise_inv in H.
              eapply ty_dec_trm_r; eauto.
        ++ assert (Hpt0 : G ⊢!!! p : T) by (eapply pt3_and_destruct1; eauto).
           assert (Hpd : G ⊢!!! p : (typ_rcd D)) by (eapply pt3_and_destruct2; eauto).
           apply* ty_and_r.
        ++ assert (Hpt0 : G ⊢!!! p : T) by (eapply pt3_and_destruct1; eauto).
           assert (Hpd : G ⊢!!! p : (typ_rcd D)) by (eapply pt3_and_destruct2; eauto).
          apply ty_and_r; eauto.
          destruct D2; invert_repl;
          apply ty_precise_inv in Hpd.
          * eapply ty_dec_typ_r; eauto. apply repl_swap in H7. eauto.
          * eapply ty_dec_typ_r; eauto.
          * eapply ty_dec_trm_r; eauto.
    -- SCase "ty_sel_qp_inv"%string.
       inversions Hr.
       specialize (ty_sel_pq_inv _ H H0 H1). intros Hr.
       rewrite <- H5 in Hr. eapply ty_sel_qp_r; eauto.
    -- SCase "ty_sngl_qp_inv"%string.
       inversions Hr.
       specialize (ty_sngl_pq_inv _ H H0 H1). intros Hr.
       rewrite <- H5 in Hr. eapply ty_sngl_qp_r; eauto.
  - Case "ty_sel_qp_r"%string.
    invert_repl. specialize (IHHp Hi _ _ H _ _ H0 (rpath q p bs A)).
    rewrite <- H4 in IHHp. eapply ty_sel_qp_r; eauto.
  - Case "ty_sngl_qp_r"%string.
    invert_repl. specialize (IHHp Hi _ _ H _ _ H0 (rsngl q p bs)).
    rewrite <- H4 in IHHp. eapply ty_sngl_qp_r; eauto.
  - Case "ty_dec_trm_r"%string.
    invert_repl. eapply ty_dec_trm_r; eauto. eapply subtyp_trans_t; eauto.
  - Case "ty_dec_typ_r"%string.
    invert_repl; eapply ty_dec_typ_r; eauto.
    -- eapply subtyp_trans_t. eapply subtyp_sngl_pq_t; eauto.
       apply repl_swap in H8. eauto. auto.
    -- eapply subtyp_trans_t. eauto.  eapply subtyp_sngl_qp_t; eauto.
  - Case "ty_all_r"%string.
    invert_repl.
    -- eapply ty_all_r with (L:=L \u dom G); eauto 2.
       * apply repl_swap in H6. eapply subtyp_trans_t.
         eapply subtyp_sngl_pq_t; eauto. auto.
       * introv Hy. eapply narrow_subtyping. apply H0. auto. constructor; auto.
         apply tight_to_general. eapply subtyp_sngl_pq_t; eauto. apply repl_swap.
         auto.
    -- eapply ty_all_r with (L:=L \u dom G); eauto 2.
       introv Hy. eapply subtyp_trans. apply H0. auto.
       eapply repl_open_var in H6; try solve_names.
       eapply subtyp_sngl_qp. apply* weaken_ty_trm. eapply precise_to_general.
       apply Hq.
       apply* weaken_ty_trm. apply* precise_to_general2. eapply H6.
Qed.

(** Replacement typing is closed under [qp] replacement
    when we know [q]'s II-level precise type *)
Lemma replacement_repl_closure_qp2 : forall G p q r T T' U,
    inert G ->
    G ⊢!! q : {{ r }} ->
    G ⊢!! r : U ->
    G ⊢// p : T ->
    repl_typ r q T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hq Hr' Hp Hr. gen U. dependent induction Hq; introv Hr'.
  - lets Heq: (pf_sngl_T Hi H). subst.
    apply* replacement_repl_closure_qp.
  - pose proof (repl_field_elim _ _ _ Hr) as Hr''.
    pose proof (pt2_backtrack _ _ Hr') as [U' Hq]. eauto.
Qed.

(** Replacement typing is closed under [qp] replacement
    when we know [q]'s III-level precise type *)
Lemma replacement_repl_closure_qp3 : forall G p q r T T' U,
    inert G ->
    G ⊢!!! q : {{ r }} ->
    G ⊢!! r : U ->
    G ⊢// p : T ->
    repl_typ r q T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hq Hr' Hp Hr. gen p T T' U. dependent induction Hq; introv Hp; introv Hr; introv Hr'.
  - apply* replacement_repl_closure_qp2.
  - specialize (IHHq _ Hi eq_refl _ _ Hp).
    destruct (repl_insert q Hr) as [V [Hr1 Hr2]].
    pose proof (pt2_exists Hq) as [S Hs].
    specialize (IHHq _ Hr1 _ Hr'). eapply replacement_repl_closure_qp2.
    auto. auto. apply H. apply Hs. apply IHHq. eauto.
Qed.

(** Replacement typing is closed under repeated [qp] replacements *)
Lemma replacement_repl_closure_qp_comp: forall G p q r T T' U,
    inert G ->
    G ⊢// p: T ->
    G ⊢!!! q: {{ r }} ->
    G ⊢!! r : U ->
    repl_repeat_typ r q T T' ->
    G ⊢// p: T'.
Proof.
  introv Hi Hp Hq Hr Hc. gen p. dependent induction Hc; introv Hp; eauto.
  apply* IHHc. apply* replacement_repl_closure_qp3.
Qed.

Lemma replacement_repl_closure_pq_helper_mutind: (forall q p T T',
    repl_typ q p T T' ->
    forall q0 r0 T2 G, repl_typ q0 r0 T' T2 ->
    inert G ->
    G ⊢! p: {{ q }} ⪼ {{ q }} ->
    G ⊢! q0: {{ r0 }} ⪼ {{ r0 }} ->
             T = T2 \/ exists T3, repl_typ q0 r0 T T3 /\ repl_typ q p T3 T2) /\
    (forall q p D D',
        repl_dec q p D D' ->
    forall q0 r0 D2 G,
    repl_dec q0 r0 D' D2 ->
    inert G ->
    G ⊢! p: {{ q }} ⪼ {{ q }} ->
    G ⊢! q0: {{ r0 }} ⪼ {{ r0 }} ->
    D = D2 \/ exists D3, repl_dec q0 r0 D D3 /\ repl_dec q p D3 D2).
Proof.
  apply repl_mutind; intros; eauto.
  - invert_repl. destruct (H _ _ _ _ H7 H1 H2 H3); subst; eauto.
    right. destruct H0 as [D4 [Hl Hr]]. exists (typ_rcd D4). split; eauto.
  - invert_repl.
    * destruct (H _ _ _ _ H9 H1 H2 H3); subst; eauto.
      right. destruct H0 as [T5 [Hl Hr]]. exists (T5 ∧ U). split; eauto.
    * right. exists (T1 ∧ T4). split; auto.
  - invert_repl.
    * right. exists (T4 ∧ T1). split; auto.
    * destruct (H _ _ _ _ H9 H1 H2 H3); subst; eauto.
      destruct H0 as [T5 [Hl Hr]]. right. exists (U ∧ T5). split; auto.
  - invert_repl. left. assert (p •• bs = r0 •• bs0).
    eapply pf_sngl_sel_unique; eauto. rewrite H. auto.
  - invert_repl. destruct (H _ _ _ _ H7 H1 H2 H3); subst; eauto.
    right. destruct H0 as [T5 [Hl Hr]]. exists (μ T5). split; auto.
  - invert_repl.
    * destruct (H _ _ _ _ H9 H1 H2 H3); subst; eauto.
      right. destruct H0 as [T5 [Hl Hr]]. exists (∀ (T5) U). split; auto.
    * right. exists (∀ (T1) T4). split; auto.
  - invert_repl.
    * right. exists (∀ (T4) T1). split; auto.
    * destruct (H _ _ _ _ H9 H1 H2 H3); subst; eauto.
      right. destruct H0 as [T5 [Hl Hr]]. exists (∀ (U) T5). split; auto.
  - invert_repl. left. assert (p •• bs = r0 •• bs0).
    eapply pf_sngl_sel_unique; eauto. rewrite H. auto.
  - invert_repl.
    * destruct (H _ _ _ _ H10 H1 H2 H3); subst; eauto.
      right. destruct H0 as [T4 [Hl Hr]]. exists (dec_typ A T4 U). split; auto.
    * right. exists (dec_typ A T1 T3). split; auto.
  - invert_repl.
    * right. exists (dec_typ A T3 T1). split; auto.
    * destruct (H _ _ _ _ H10 H1 H2 H3); subst; eauto.
      right. destruct H0 as [T4 [Hl Hr]]. exists (dec_typ A U T4). split; auto.
  - invert_repl. destruct (H _ _ _ _ H9 H1 H2 H3); subst; eauto.
    right. destruct H0 as [T4 [Hl Hr]]. exists ({a ⦂ T4}). split; auto.
Qed.

Lemma replacement_repl_closure_pq_helper: forall p q T T',
    repl_typ q p T T' ->
    forall q0 r0 T2 G, repl_typ q0 r0 T' T2 ->
    inert G ->
    G ⊢! p: {{ q }} ⪼ {{ q }} ->
    G ⊢! q0: {{ r0 }} ⪼ {{ r0 }} ->
    T = T2 \/ exists T3, repl_typ q0 r0 T T3 /\ repl_typ q p T3 T2.
Proof.
  destruct replacement_repl_closure_pq_helper_mutind; eauto.
Qed.

Lemma invertible_repl_closure_helper :
  (forall D,
      record_dec D -> forall G p q r D' U,
      inert G ->
      G ⊢!!! p: typ_rcd D ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : U ->
      repl_dec q r D D' ->
      G ⊢// p: typ_rcd D') /\
  (forall U ls,
      record_typ U ls -> forall G p q r U' V,
      inert G ->
      G ⊢!!! p: U ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : V ->
      repl_typ q r U U' ->
      G ⊢// p: U') /\
  (forall U,
      inert_typ U -> forall G p q r U' V,
      inert G ->
      G ⊢!!! p: U ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : V ->
      repl_typ q r U U' ->
      G ⊢// p: U').
Proof.
  apply rcd_mutind; intros; try solve [invert_repl; eauto].
  - invert_repl; eapply ty_dec_typ_r. eapply ty_inv_r.
    eapply ty_precise_inv. apply H0.
    solve_repl_sub. eauto. solve_repl_sub. eauto. eauto.
  - invert_repl. eapply ty_dec_trm_r. eapply ty_inv_r.
    eapply ty_precise_inv. eauto. eauto.
  - invert_repl. eapply ty_dec_trm_r. eapply ty_inv_r.
    eapply ty_precise_inv. eauto. eauto.
  - invert_repl; eapply ty_and_r. apply* H. apply* pt3_and_destruct1.
    apply pt3_and_destruct2 in H2; auto.
    apply pt3_and_destruct1 in H2; auto.
    invert_repl. apply pt3_and_destruct2 in H2; auto. eauto.
  - pose proof (typed_paths_named (precise_to_general H1)) as Ht.
    invert_repl; eapply ty_all_r with (L:=dom G). eauto. apply repl_swap in H9. eauto.
    introv Hy. eauto. eauto. eauto.
    introv Hy.
    pose proof (typed_paths_named (precise_to_general2 H2)) as Hs.
    lets Ho: (repl_open_var y H9 Ht Hs). eapply weaken_subtyp. solve_repl_sub.
    apply* ok_push.
Qed.

(** Singleton-subtyping closure for invertible typing:
    If [Γ ⊢## p: T] and [Γ ⊢! q: r.type] then [Γ ⊢## p: T[r/q]] *)
Lemma invertible_repl_closure : forall G p q r T T' U,
    inert G ->
    G ⊢## p : T ->
    G ⊢! q : {{ r }} ⪼ {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hp Hqr Hr Hrep. gen q r T' U.
  induction Hp; introv Hq; introv Hrep; introv Hr'.
  - Case "ty_precise_inv"%string.
    destruct (pt3_inertsngl Hi H) as [[Hin | Hs] | Hr].
    * inversions Hin.
      ** apply* invertible_repl_closure_helper.
      ** invert_repl. eauto.
    * inversions Hs. invert_repl. eapply ty_inv_r. eapply ty_sngl_pq_inv; eauto.
    * inversions Hr. eapply (proj32 invertible_repl_closure_helper); eauto.
  - Case "ty_rec_pq_inv"%string.
    invert_repl. eauto.
  - Case "ty_sel_pq_inv"%string.
    assert (exists r''', T' = r'''↓A) as [r''' Heq]. {
      invert_repl. eauto.
    } subst.
    destruct (repl_prefixes_sel Hrep) as [bs0 [He1 He2]]. subst.
    apply ty_inv_r.
    apply ty_sel_pq_inv with (p:=q0) (U:=U0); auto.
    rewrite <- He1; auto. eapply ty_sel_pq_inv; eauto.
  - Case "ty_sngl_qp_inv"%string.
    assert (exists r''', T' = {{ r'''}}) as [r''' Heq]. {
      invert_repl. eauto.
    } subst.
    destruct (repl_prefixes_sngl Hrep) as [bs0 [He1 He2]]. subst.
    apply ty_inv_r.
    apply ty_sngl_pq_inv with (p:=q0) (U:=U0); auto.
    rewrite <- He1; auto. eapply ty_sngl_pq_inv; eauto.
Qed.

(** Replacement typing is closed under [pq] replacement
    when we know [q]'s precise type *)
Lemma replacement_repl_closure_pq : forall G p q r T T' U,
    inert G ->
    G ⊢// p : T ->
    G ⊢! q : {{ r }} ⪼ {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hp Hq Hqr.
  gen q r T' U. induction Hp; introv Hq; introv Hr' Hr; eauto.
   - Case "ty_inv_r"%string.
     apply* invertible_repl_closure.
   - Case "ty_and_r"%string.
     invert_repl; eauto.
   - Case "ty_bnd_r"%string.
     invert_repl. apply (repl_open p) in H2; try solve_names. eauto.
   - Case "ty_sel_r"%string.
     clear IHHp. invert_repl. lets Heq: (pf_sngl_flds_elim _ Hi Hq H). subst.
     rewrite field_sel_nil in *.
     lets Heq: (pf_T_unique Hi H Hq). subst.
     apply pf_sngl_U in H. inversion H.
   - Case "ty_rcd_intro_r"%string. invert_repl. eauto.
   - Case "ty_rec_qp_r"%string.
     invert_repl. specialize (IHHp Hi _ _ Hq).
     destruct (replacement_repl_closure_pq_helper H1 H5 Hi H Hq).
     * rewrite <- H2. auto.
     * destruct H2 as [T3 [Hl Hr]].
       assert (G ⊢// r : μ T3) by (eapply IHHp; eauto).
       apply (ty_rec_qp_r H H0 H2 Hr).
   - Case "ty_sel_pq_r"%string. invert_repl.
     specialize (pf_sngl_sel_unique _ _ Hi H Hq H4) as Heq. rewrite <- Heq.
     auto.
   - Case "ty_sngl_pq_r"%string. invert_repl.
     specialize (pf_sngl_sel_unique _ _ Hi H Hq H4) as Heq. rewrite <- Heq.
     auto.
   - Case "ty_top_r"%string. invert_repl.
   - Case "ty_dec_trm_r"%string. invert_repl. eapply ty_dec_trm_r; eauto.
     eapply subtyp_trans_t; eauto.
   - Case "ty_dec_typ_r"%string. invert_repl; eapply ty_dec_typ_r; eauto.
     * eapply subtyp_trans_t. apply repl_swap in H8. eapply subtyp_sngl_qp_t; eauto.
       auto.
     * eapply subtyp_trans_t; eauto.
   - Case "ty_all_r"%string. invert_repl; eapply ty_all_r with (L:=L \u dom G); eauto 2.
     * eapply subtyp_trans_t. apply repl_swap in H6. eapply subtyp_sngl_qp_t; eauto.
       auto.
     * introv Hy. eapply narrow_subtyping. apply H0. eauto.
       constructor; auto. apply tight_to_general.
       eapply subtyp_sngl_qp_t; eauto. apply repl_swap; auto.
     * introv Hy. apply repl_swap in H6. eapply subtyp_trans.
       + apply H0. eauto.
       + eapply repl_open_var in H6; try solve_names.
         eapply subtyp_sngl_pq. apply* weaken_ty_trm.
         eapply precise_to_general. apply Hq.
         apply* weaken_ty_trm. apply* precise_to_general2.
         apply repl_swap in H6. eauto.
Qed.

(** Replacement typing is closed under [pq] replacement
    when we know [q]'s II-level precise type *)
Lemma replacement_repl_closure_pq2 : forall G p q r T T' U,
    inert G ->
    G ⊢// p : T ->
    G ⊢!! q : {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hp Hq Hr' Hr. gen U. dependent induction Hq; introv Hr'.
  - apply* replacement_repl_closure_pq. lets Heq: (pf_sngl_T Hi H). subst. auto.
  - pose proof (repl_field_elim _ _ _ Hr).
    pose proof (pt2_backtrack _ _ Hr') as [U' Hq'].
    specialize (IHHq1 _ Hi Hp eq_refl H _ Hq').
    eauto.
Qed.

(** Replacement typing is closed under [pq] replacement
    when we know [q]'s III-level precise type *)
Lemma replacement_repl_closure_pq3 : forall G p q r T T' U,
    inert G ->
    G ⊢// p : T ->
    G ⊢!!! q : {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢// p : T'.
Proof.
  introv Hi Hp Hq Hr. gen p T U. dependent induction Hq; introv Hp; introv Hr' Hr.
  - apply* replacement_repl_closure_pq2.
  - destruct (repl_insert q Hr) as [U' [Hr1 Hr2]].
    pose proof (pt2_exists Hq) as [S Hq'].
    lets Hc: (replacement_repl_closure_pq2 Hi Hp H Hq' Hr1). apply* IHHq.
Qed.

(** Replacement typing is closed under repeated [pq] replacement *)
Lemma replacement_repl_closure_pq_comp: forall G p q r T T' U,
    inert G ->
    G ⊢// p: T ->
    G ⊢!!! q: {{ r }} ->
    G ⊢!! r : U ->
    repl_repeat_typ q r T T' ->
    G ⊢// p: T'.
Proof.
  introv Hi Hp Hq Hr Hc. gen p. dependent induction Hc; introv Hp; eauto.
  apply* IHHc. apply* replacement_repl_closure_pq3.
Qed.

(** Replacement typing is closed under opening of recursive types *)
Lemma repl_rec_intro: forall G p T,
    inert G ->
    G ⊢// p: μ T ->
    G ⊢// p: open_typ_p p T.
Proof.
  introv Hi Hp. dependent induction Hp; auto.
  - Case "ty_inv_r"%string.
    dependent induction H.
    + destruct (pt3_bnd Hi H) as [Hp | [q [U [Hp1 [Hq Hp2]]]]].
      * eapply ty_inv_r. eapply ty_precise_inv. eauto.
      * eapply replacement_repl_closure_qp_comp. auto. auto. apply* ty_inv_r.
        apply Hp1. eauto. apply* repl_comp_open.
    + specialize (IHty_path_inv _ eq_refl Hi).
      eapply replacement_repl_closure_pq; eauto.
      apply* repl_open. all: solve_names.
  - Case "ty_rec_pq_r"%string.
    specialize (IHHp _ Hi eq_refl).
    apply repl_open with (r:= r) in H1; try solve_names. apply* replacement_repl_closure_qp.
Qed.

(** Replacement typing is closed under [<:-Sel] subtyping when
    we know that a path's II-level precise type has a type member *)
Lemma path_sel_repl2: forall G p A T q,
    inert G ->
    G ⊢!! p : typ_rcd {A >: T <: T} ->
    G ⊢// q : T ->
    G ⊢// q : p ↓ A.
Proof.
  introv Hi Hp Hq. dependent induction Hp; eauto.
Qed.

(** Replacement typing is closed under [<:-Sel] subtyping when
    we know that a path's III-level precise type has a type member *)
Lemma path_sel_repl: forall G p A T q,
    inert G ->
    G ⊢!!! p : typ_rcd {A >: T <: T} ->
    G ⊢// q : T ->
    G ⊢// q : p ↓ A.
Proof.
  introv Hi Hp Hq. dependent induction Hp; eauto.
  apply* path_sel_repl2.
 specialize (IHHp _ _ Hi eq_refl Hq).
  assert (forall q, q = q •• nil) as Hnil. {
    intro. rewrite* field_sel_nil.
  }
  lets He1: (Hnil q0). lets He2: (Hnil p).
  pose proof (pt2_exists Hp) as [U Hp0].
  eapply (replacement_repl_closure_qp2 Hi H Hp0 IHHp).
  rewrite He1 at 2. rewrite He2 at 2. apply rpath.
Qed.

(** Replacement typing is closed under [Sel-<:] subtyping *)
Lemma path_sel_repl_inv: forall G p A T q,
    inert G ->
    G ⊢!!! p : typ_rcd {A >: T <: T} ->
    G ⊢// q : p ↓ A ->
    G ⊢// q : T.
Proof.
  introv Hi Hp Hq. dependent induction Hq.
  - Case "ty_inv_r"%string.
    constructor. apply* path_sel_inv.
  - Case "ty_sel_r"%string.
    clear IHHq. lets Heq: (pf_pt3_unique Hi H Hp). subst*.
  - Case "ty_sel_qp_r"%string.
    assert (record_type (typ_rcd {A >: T <: T})) as Hrt by eauto.
    apply IHHq with (p := q •• bs) (A0 := A); eauto.
    eapply pf_pt3_trans_inv_mult'; eauto.
Qed.

(** If a path has a replacement type it has also an invertible type *)
Lemma repl_to_inv G p T :
  G ⊢// p : T ->
  exists U, G ⊢## p : U.
Proof.
  induction 1; eauto. destruct IHty_repl as [U Hp].
  clear H. apply inv_backtrack in Hp. eauto.
Qed.

(** Replacement typing is closed under tight subtyping *)
Lemma replacement_subtyping_closure : forall G T U p,
    inert G ->
    G ⊢# T <: U ->
    G ⊢// p: T ->
    G ⊢// p: U.
Proof.
  introv Hi Hs. gen p. induction Hs; introv Hp; eauto.
  - Case  "subtyp_bot"%string.
    inversions Hp. false* invertible_bot.
  - Case "subtyp_and1"%string.
    apply (repl_and Hi) in Hp. destruct_all. auto.
  - Case "subtyp_and2"%string.
    apply (repl_and Hi) in Hp. destruct_all. auto.
  - Case "subtyp_sngl_pq"%string.
    pose proof (pt2_exists H0) as [? ?].
    apply* replacement_repl_closure_pq3.
  - Case "subtyp_sngl_qp"%string.
    pose proof (pt2_exists H0) as [? ?].
    apply* replacement_repl_closure_qp3.
  - Case "subtyp_sel2"%string.
    apply* path_sel_repl.
  - Case "subtyp_sel1"%string.
    apply* path_sel_repl_inv.
Qed.

(** If a path has a replacement type it also has a III-level precise type *)
Lemma repl_prec_exists: forall G p T,
    G ⊢// p: T ->
    exists U, G ⊢!!! p: U.
Proof.
  introv Hp. apply repl_to_inv in Hp as [? Hp].
  induction Hp; eauto.
Qed.

(** Replacement is closed under field selection on paths *)
Lemma repl_fld : forall G p a T,
    inert G ->
    G ⊢// p: typ_rcd {a ⦂ T} ->
    G ⊢// p•a : T.
Proof.
  introv Hi Hp. dependent induction Hp; eauto.
  dependent induction H; eauto.
  - dependent induction H.
    * dependent induction H; eauto.
      apply pf_fld in H; apply ty_inv_r; apply* ty_precise_inv.
    * lets Hq: (pt3_field_elim H0).
      lets Hp: (pt3_trans _ H Hq). eauto.
  - specialize (IHHp _ _ Hi eq_refl).
    eapply replacement_subtyping_closure; eauto.
Qed.

(** If [G ⊢// p: T] and [T] and [T'] are equivalent then [G ⊢// p: T'] *)
Lemma replacement_repl_closure_comp_typed: forall G p T T',
    inert G ->
    G ⊢// p: T ->
    G ⊢ T' ⟿ T ->
    G ⊢// p: T'.
Proof.
  introv Hi Hp Hr. dependent induction Hr; eauto.
  destruct H as [p' [q' [S [Hpq [Hq Hr']]]]].
  lets Hrc: (replacement_repl_closure_qp Hi Hpq Hq Hp Hr'). eauto.
Qed.

(** From replacement typing of singleton types to invertible typing of singleton types *)
Lemma repl_to_invertible_sngl_repl_comp: forall G p q,
    inert G ->
    G ⊢// p: {{ q }} ->
    exists q', G ⊢ q ⟿' q' /\ G ⊢## p: {{ q' }}.
Proof.
  introv Hi Hp. dependent induction Hp.
  - Case "ty_inv_r"%string.
    exists q. split*. apply star_refl.
  - Case "ty_sngl_qp_r"%string.
    specialize (IHHp _ Hi eq_refl). destruct IHHp as [p' [Hr Hr']].
    eexists. split*. eapply star_trans. apply Hr.  apply star_one. repeat eexists; eauto.
Qed.

(** If a path [p] has type [q.type] under replacement typing and [q] is well-typed,
    then the invertible type of [p] has a singleton type [q'.type], and [q] and [q']
    are aliases. *)
Lemma repl_to_invertible_sngl: forall G p q U,
    inert G ->
    G ⊢// p: {{ q }} ->
    G ⊢!! q : U ->
    exists q' S, G ⊢## p: {{ q' }} /\ G ⊢!! q' : S /\ (q = q' \/ G ⊢!!! q: {{ q' }}).
Proof.
  introv Hi Hp Hq. gen U. dependent induction Hp; introv Hq.
  - repeat eexists; eauto.
  - destruct (pt2_qbs_typed _ Hi H H0 Hq) as [T Hq0bs].
    specialize (IHHp _ Hi eq_refl _ Hq0bs).
    destruct IHHp as [q' [S [Hr [Hq' [Heq | Hq0']]]]]. subst.
    + exists (q0 •• bs) T. split; auto. split; auto. right.
      eapply pt3_trans_trans; eauto.
    + exists q' S. split; auto. split; auto. right. eapply pt3_sngl_trans; eauto.
      eapply pt2_field_trans; eauto.
Qed.

Lemma replacement_repl_closure_comp_typed_path: forall G p q q',
    inert G ->
    G ⊢// p: {{ q }} ->
    G ⊢ q' ⟿' q ->
    G ⊢// p: {{ q' }}.
Proof.
  introv Hi Hp Hr. dependent induction Hr; eauto.
  inversions H. apply IHHr. eapply ty_sngl_qp_r; eauto.
Qed.

(** If [p]'s replacement type is [q.type] and [q] is well-typed, then
    [p.a]'s replacement type is [q.a.type] *)
Lemma path_elim_repl: forall G p q a T,
    inert G ->
    G ⊢// p: {{ q }} ->
    G ⊢// q•a : T ->
    G ⊢// p•a : {{ q•a }}.
Proof.
  introv Hi Hp Hq.
  destruct (repl_to_invertible_sngl_repl_comp Hi Hp) as [p' [Hc Hpi]].
  destruct (inv_to_precise_sngl_repl_comp Hpi) as [r' [Hp' Hrc]].
  destruct (repl_prec_exists Hq) as [U Hq']. clear Hq.
  destruct (field_typing_comp1 _ Hi Hc Hq') as [T1 Hra].
  destruct (field_typing_comp2 _ Hi Hrc Hra) as[T2 Hr'a].
  lets Hper: (path_elim_prec _ Hi Hp' Hr'a).
  lets Hinv: (ty_precise_inv Hper).
  assert (G ⊢ r' • a ⟿' p' • a) as Hr'
      by apply* repl_composition_fld_elim.
  assert (G ⊢ q • a ⟿' p' • a) as Hr''
      by apply* repl_composition_fld_elim.
  lets Hic: (invertible_repl_closure_comp_typed Hi Hinv Hr').
  apply* replacement_repl_closure_comp_typed_path.
Qed.

(** Replacement typing is closed under singleton transitivity with a type [q.type]
    if [q] is typeable under invertible typing *)
Lemma inv_sngl_trans: forall G p q T,
    inert G ->
    G ⊢// p : {{ q }} ->
    G ⊢## q : T ->
    G ⊢// p : T.
Proof.
  introv Hi Hpq Hq. gen p. induction Hq; introv Hpq; eauto; try solve [apply* replacement_repl_closure_pq].
  - pose proof (pt2_exists H) as [U H'].
    destruct (repl_to_invertible_sngl Hi Hpq H') as [r [S [Hpr [Hq Hrc]]]].
    destruct (inv_to_precise_sngl Hi Hpr (pt3 Hq)) as [r' [Hpr' Hrc']]. clear Hpr Hpq H'.
    destruct Hrc, Hrc'; subst.
    * do 2 constructor. apply* pt3_sngl_trans3.
    * do 2 constructor. repeat apply* pt3_sngl_trans3.
    * lets Hpi: (pt3_invert Hi H H0). destruct_all; subst; auto.
      ** do 2 constructor. apply* pt3_sngl_trans3.
      ** apply ty_precise_inv in Hpr'. apply ty_inv_r in Hpr'.
         apply* replacement_repl_closure_qp3. apply* repl_intro_sngl.
    * lets Hpi: (pt3_invert Hi H H0). destruct_all; subst.
      ** do 2 constructor. do 2 apply* pt3_sngl_trans3.
      ** do 2 constructor. apply* pt3_sngl_trans3.
      ** apply ty_precise_inv in Hpr'. apply ty_inv_r in Hpr'.
         lets Hc: (replacement_repl_closure_pq3 Hi Hpr' H1 Hq (repl_intro_sngl r' r)).
         apply* replacement_repl_closure_qp3. apply* repl_intro_sngl.
Qed.

(** Replacement typing is closed under singleton transitivity *)
Lemma repl_sngl_trans: forall G p q T,
    inert G ->
    G ⊢// p : {{ q }} ->
    G ⊢// q : T ->
    G ⊢// p : T.
Proof.
  introv Hi Hpq Hq. gen p. induction Hq; introv Hpq; eauto.
  - apply* inv_sngl_trans.
  - specialize (IHHq Hi _ Hpq). apply ty_bnd_r.
    pose proof (repl_to_inv Hq) as [_ [_ [U Hq']%pt2_exists]%inv_to_prec].
    destruct (repl_to_invertible_sngl Hi Hpq Hq') as [r [S [Hpr [Hs Hor]]]].
    destruct (inv_to_precise_sngl Hi Hpr (pt3 Hs)) as [r' [Hpr' Hor']]. clear Hpr Hpq.
    destruct Hor, Hor'; subst.
    * assert (repl_repeat_typ r p0 (open_typ_p r T) (open_typ_p p0 T)) as Hrr by apply* repl_comp_open_rec.
      apply* replacement_repl_closure_qp_comp.
    * assert (repl_repeat_typ r r' (open_typ_p r T) (open_typ_p r' T)) as Hrr by apply* repl_comp_open_rec.
      lets Hc: (replacement_repl_closure_qp_comp Hi IHHq H0 Hs Hrr).
      apply pt2_exists in H0 as [? ?].
      eapply (replacement_repl_closure_qp_comp Hi Hc). apply Hpr'. eauto.
      apply* repl_comp_open_rec.
    * assert (repl_repeat_typ p r (open_typ_p p T) (open_typ_p r T)) as Hrr by apply* repl_comp_open_rec.
      lets Hc: (replacement_repl_closure_pq_comp Hi IHHq H Hs Hrr).
      apply* replacement_repl_closure_qp_comp. apply* repl_comp_open_rec.
    * assert (repl_repeat_typ p r (open_typ_p p T) (open_typ_p r T)) as Hrr by apply* repl_comp_open_rec.
      lets Hc: (replacement_repl_closure_pq_comp Hi IHHq H Hs Hrr).
      assert (repl_repeat_typ r r' (open_typ_p r T) (open_typ_p r' T)) as Hrr' by apply* repl_comp_open_rec.
      lets Hc': (replacement_repl_closure_qp_comp Hi Hc H0 Hs Hrr').
      pose proof (pt2_exists H0) as [? ?].
      eapply (replacement_repl_closure_qp_comp Hi). auto. apply Hc'. apply Hpr'. eauto. apply* repl_comp_open_rec.
  - pose proof (path_elim_repl _ Hi Hpq Hq) as Hp0a. specialize (IHHq Hi _ Hp0a). eauto.
Qed.

(** Tight typing implies replacement typing *)
Lemma replacement_closure : forall G p T,
  inert G ->
  G ⊢# trm_path p : T ->
  G ⊢// p: T.
Proof.
  introv Hi Hp. dependent induction Hp; eauto.
  - Case "ty_var_t"%string.
    repeat econstructor; eauto.
  - Case "ty_new_elim_t"%string.
    apply* repl_fld.
  - Case "ty_sngl_t"%string.
    apply* repl_sngl_trans.
  - Case "ty_path_elim_t"%string.
    apply* path_elim_repl.
  - Case "ty_rec_elim_t"%string.
    specialize (IHHp _ Hi eq_refl). apply* repl_rec_intro.
  - Case "ty_sub_t"%string.
    specialize (IHHp _ Hi eq_refl).
    eapply replacement_subtyping_closure; eauto.
Qed.

(** ** Replacement typing for values

    The definition of replacement typing for values
    is similar to replacement typing for paths, but simpler. The same holds for
    its lemmas. To see the documentation for a replacement-typing-for-values lemma,
    please refer to its replacement-typing-for-paths version. *)

Reserved Notation "G '⊢//v' v ':' T" (at level 40, v at level 59).

Inductive ty_replv : ctx -> val -> typ -> Prop :=
| ty_inv_rv : forall G v T,
    G ⊢##v v: T ->
    G ⊢//v v: T
| ty_and_rv : forall G v T U,
    G ⊢//v v: T ->
    G ⊢//v v: U ->
    G ⊢//v v: T ∧ U
| ty_sel_rv : forall G v T q S A,
    G ⊢//v v: T ->
    G ⊢! q: S ⪼ typ_rcd {A >: T <: T} ->
    G ⊢//v v: q ↓ A
| ty_rec_qp_rv : forall G p q v T T' U,
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q : U ->
    G ⊢//v v : μ T ->
    repl_typ q p T T' ->
    G ⊢//v v : μ T'
| ty_sel_qp_rv : forall G p q v r' r'' A U,
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q : U ->
    G ⊢//v v : r' ↓ A ->
    repl_typ q p (r' ↓ A) (r'' ↓ A) ->
    G ⊢//v v : r''↓A
(** [G ⊢## p: T]   #
#
    [―――――――――――――] #
#
    [G ⊢## p: top]     *)
| ty_top_rv : forall G v T,
  G ⊢//v v : T ->
  G ⊢//v v : ⊤

| ty_all_rv : forall G T1 T2 S1 S2 L v,
  G ⊢//v v : ∀(S1) T1 ->
  G ⊢# S2 <: S1 ->
  (forall y, y \notin L ->
   G & y ~ S2 ⊢ open_typ y T1 <: open_typ y T2) ->
  G ⊢//v v : ∀(S2) T2

where "G '⊢//v' v ':' T" := (ty_replv G v T).

Hint Constructors ty_replv.

Lemma invertible_andv: forall G v T U,
    inert G ->
    G ⊢##v v: T ∧ U ->
    G ⊢##v v: T /\ G ⊢##v v: U.
Proof.
  introv Hi Hp. dependent induction Hp; eauto. inversion H.
Qed.

Lemma repl_andv: forall G v T U,
    inert G ->
    G ⊢//v v: T ∧ U ->
    G ⊢//v v: T /\ G ⊢//v v: U.
Proof.
  introv Hi Hv. dependent induction Hv; eauto.
  destruct (invertible_andv Hi H). split*.
Qed.

Lemma replacement_repl_closure_qp_v G v p q T T' U :
    inert G ->
    G ⊢! p : {{ q }} ⪼ {{ q }} ->
    G ⊢!! q : U ->
    G ⊢//v v : T ->
    repl_typ q p T T' ->
    G ⊢//v v : T'.
Proof.
  intros Hi Hpq Hq Hv.
  gen p q T' U. induction Hv; introv Hpq; introv Hq Hr.
  - Case "ty_inv_rv"%string.
    gen p q T' U. induction H; introv Hpq; introv Hr; introv Hq;
    try solve [invert_repl; eauto].
    -- destruct (pfv_inert H).
      + invert_repl.
        ++ eapply ty_all_rv with (L := \{}).
           eapply ty_inv_rv.
           eapply ty_precise_invv. apply H.
           apply repl_swap in H5.
           eauto.
           introv Hy. auto.
        ++ eapply ty_all_rv with (L := dom G).
           eapply ty_inv_rv.
           eapply ty_precise_invv. apply H.
           auto.
           introv Hy.
           eapply repl_open_var in H5; try solve_names.
           eapply subtyp_sngl_qp. apply* weaken_ty_trm.
           eapply precise_to_general. apply Hpq. apply weaken_ty_trm; auto. apply* precise_to_general2. apply H5.
      + invert_repl; eauto.
  - Case "ty_and_rv"%string.
    invert_repl; eauto.
  - Case "ty_sel_rv"%string.
    invert_repl; eauto.
  - Case "ty_rec_qp_rv"%string.
    invert_repl; eauto.
  - Case "ty_sel_qp_rv"%string.
    lets ?: (ty_sel_qp_rv H H0 Hv H1).
    invert_repl; eauto.
  - Case "ty_top_rv"%string.
    invert_repl; eauto.
  - Case "ty_all_rv"%string.
    invert_repl; eauto.
    -- eapply ty_all_rv with (L:=L \u dom G); eauto 2.
      + eapply subtyp_trans_t. eapply subtyp_sngl_pq_t; eauto 4.
        apply repl_swap in H6. eauto 2. eauto 2.
      + introv Hy. eapply narrow_subtyping. apply H0. auto. constructor; auto.
        apply tight_to_general. eapply subtyp_sngl_pq_t; eauto.
        apply repl_swap. auto.
    -- eapply ty_all_rv with (L:=L \u dom G); eauto 2.
       introv Hy. eapply subtyp_trans. apply H0. auto.
       eapply repl_open_var in H6; try solve_names.
       eapply subtyp_sngl_qp. apply* weaken_ty_trm. eapply precise_to_general.
       apply Hpq. apply* weaken_ty_trm. apply* precise_to_general2. eapply H6.
Qed.

Lemma replacement_repl_closure_qp2_v : forall G p v r T T' U,
    inert G ->
    G ⊢!! p : {{ r }} ->
    G ⊢!! r : U ->
    G ⊢//v v : T ->
    repl_typ r p T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hp Hr Hv Hrp. gen U. dependent induction Hp; introv Hr.
  - lets Heq: (pf_sngl_T Hi H). subst.
    apply* replacement_repl_closure_qp_v.
  - lets Hr': (repl_field_elim _ _ _ Hrp). pose proof (pt2_backtrack _ _ Hr) as [? Hq']. eauto.
Qed.

Lemma replacement_repl_closure_qp3_v : forall G v p r T T' U,
    inert G ->
    G ⊢!!! p : {{ r }} ->
    G ⊢!! r : U ->
    G ⊢//v v : T ->
    repl_typ r p T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hp Hr Hv Hrp. gen v T T' U. dependent induction Hp; introv Hv; introv Hrp; introv Hr.
  - apply* replacement_repl_closure_qp2_v.
  - specialize (IHHp _ Hi eq_refl).
    destruct (repl_insert q Hrp) as [U' [Hr1 Hr2]].
    pose proof (pt2_exists Hp) as [W Hp'].
    specialize (IHHp _ _ Hv _ Hr1). eapply replacement_repl_closure_qp2_v.
    auto. eauto. eauto. apply* IHHp. eauto.
Qed.

Lemma invertible_repl_closure_v_helper :
  (forall D,
      record_dec D -> forall G v q r D' T,
      inert G ->
      G ⊢!v v: typ_rcd D ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : T ->
      repl_dec q r D D' ->
      G ⊢//v v: typ_rcd D') /\
  (forall U ls,
      record_typ U ls -> forall G v q r U' T,
      inert G ->
      G ⊢!v v: U ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : T ->
      repl_typ q r U U' ->
      G ⊢//v v: U') /\
  (forall U,
      inert_typ U -> forall G v q r U' T,
      inert G ->
      G ⊢!v v: U ->
      G ⊢! q : {{ r }} ⪼ {{ r }} ->
      G ⊢!! r : T ->
      repl_typ q r U U' ->
      G ⊢//v v: U').
Proof.
  apply rcd_mutind; intros; try solve [invert_repl; eauto].
  - inversions H0.
  - inversions H1.
  - inversions H0.
  - inversions H2.
  - lets Ht: (typed_paths_named (precise_to_general H1)).
    invert_repl; eapply ty_all_rv with (L:=dom G).
    * eauto.
    * apply repl_swap in H9. eauto.
    * eauto.
    * eauto.
    * eauto.
    * introv Hy. lets Ho: (repl_open_var y H9 Ht).
      eapply weaken_subtyp; auto.
      pose proof (typed_paths_named (precise_to_general2 H2)) as Hs.
      specialize (Ho Hs). solve_repl_sub.
Qed.

Lemma invertible_repl_closure_v : forall G v q r T T' U,
    inert G ->
    G ⊢##v v : T ->
    G ⊢! q : {{ r }} ⪼ {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hv Hqr Hr Hrep. gen q r T' U.
  induction Hv; introv Hq; introv Hr; introv Hrep.
  - Case "ty_precise_invv"%string.
    lets Ht: (pfv_inert H).
    inversions Ht.
    * apply* invertible_repl_closure_v_helper.
    * invert_repl; eauto.
  - Case "ty_rec_pq_invv"%string.
    invert_repl. eauto.
Qed.

Lemma replacement_repl_closure_pq_v : forall G v q r T T' U,
    inert G ->
    G ⊢//v v : T ->
    G ⊢! q : {{ r }} ⪼ {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hv Hqr Hr'.
  gen q r T' U. induction Hv; introv Hq; introv Hr' Hr; eauto.
   - Case "ty_inv_rv"%string.
     apply* invertible_repl_closure_v.
   - Case "ty_and_rv"%string.
     invert_repl; eauto.
   - Case "ty_sel_rv"%string.
     clear IHHv. invert_repl. lets Heq: (pf_sngl_flds_elim _ Hi Hq H). subst.
     rewrite field_sel_nil in *.
     lets Heq: (pf_T_unique Hi H Hq). subst.
     apply pf_sngl_U in H. inversion H.
  - Case "ty_rec_qp_rv"%string.
    invert_repl. specialize (IHHv Hi _ _ Hq).
    destruct (replacement_repl_closure_pq_helper H1 H5 Hi H Hq).
    * rewrite <- H2. auto.
    * destruct H2 as [T3 [Hl Hr]].
      assert (G ⊢//v v : μ T3) by (eapply IHHv; eauto).
      apply (ty_rec_qp_rv H H0 H2 Hr).
  - Case "ty_sel_pq_rv"%string. invert_repl.
    specialize (IHHv Hi _ _ Hq).
    assert (q •• bs0 = r •• bs). eapply pf_sngl_sel_unique; eauto.
    rewrite <- H1. auto.
  - Case "ty_top_rv"%string. invert_repl.
  - Case "ty_all_rv"%string.
    invert_repl; eapply ty_all_rv with (L:=L \u dom G); eauto 2.
    * eapply subtyp_trans_t. apply repl_swap in H6. eapply subtyp_sngl_qp_t; eauto.
      auto.
    * introv Hy. eapply narrow_subtyping. apply H0. eauto.
      constructor; auto. apply tight_to_general.
      eapply subtyp_sngl_qp_t; eauto. apply repl_swap; auto.
    * introv Hy. apply repl_swap in H6. eapply subtyp_trans.
      + apply H0. eauto.
      + eapply repl_open_var in H6; try solve_names.
        eapply subtyp_sngl_pq. apply* weaken_ty_trm.
        eapply precise_to_general. apply Hq.
        apply* weaken_ty_trm. apply* precise_to_general2.
        apply repl_swap in H6. eauto.
Qed.

Lemma replacement_repl_closure_pq2_v : forall G v q r T T' U,
    inert G ->
    G ⊢//v v : T ->
    G ⊢!! q : {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hv Hq Hr' Hr. gen U. dependent induction Hq; introv Hr'.
  - apply* replacement_repl_closure_pq_v.
    lets Heq: (pf_sngl_T Hi H). subst. auto.
  - lets Hr'': (repl_field_elim _ _ _ Hr). pose proof (pt2_backtrack _ _ Hr') as [? ?]. eauto.
Qed.

Lemma replacement_repl_closure_pq3_v : forall G v q r T T' U,
    inert G ->
    G ⊢//v v : T ->
    G ⊢!!! q : {{ r }} ->
    G ⊢!! r : U ->
    repl_typ q r T T' ->
    G ⊢//v v : T'.
Proof.
  introv Hi Hv Hq Hr Hr'. gen v T U. dependent induction Hq; introv Hv Hr; introv Hr'.
  - apply* replacement_repl_closure_pq2_v.
  - destruct (repl_insert q Hr) as [? [Hr1 Hr2]].
    pose proof (pt2_exists Hq) as [? Hq'].
    lets Hc: (replacement_repl_closure_pq2_v Hi Hv H Hq' Hr1). apply* IHHq.
Qed.

Lemma path_sel_repl2_v: forall G p A T v,
    inert G ->
    G ⊢!! p : typ_rcd {A >: T <: T} ->
    G ⊢//v v : T ->
    G ⊢//v v : p↓A.
Proof.
  introv Hi Hp Hv. dependent induction Hp; eauto.
Qed.

Lemma path_sel_repl_v: forall G p A T v,
    inert G ->
    G ⊢!!! p : typ_rcd {A >: T <: T} ->
    G ⊢//v v : T ->
    G ⊢//v v : p↓A.
Proof.
  introv Hi Hp Hv. dependent induction Hp; eauto.
  apply* path_sel_repl2_v.
  specialize (IHHp _ _ Hi eq_refl Hv).
  assert (forall q, q = q •• nil) as Hnil. {
    intro. rewrite* field_sel_nil.
  }
  lets He1: (Hnil q). lets He2: (Hnil p).
  pose proof (pt2_exists Hp) as [? Hq].
  eapply (replacement_repl_closure_qp2_v Hi H Hq IHHp).
  rewrite He1 at 2. rewrite He2 at 2. apply rpath.
Qed.

Lemma path_sel_repl_inv_v: forall G p A T v,
    inert G ->
    G ⊢!!! p : typ_rcd {A >: T <: T} ->
    G ⊢//v v : p↓A ->
    G ⊢//v v : T.
Proof.
  introv Hi Hp Hv. dependent induction Hv.
  - Case "ty_inv_r"%string.
    constructor. apply* path_sel_inv_v.
  - Case "ty_sel_r"%string.
    clear IHHv. lets Heq: (pf_pt3_unique Hi H Hp). subst*.
  - Case "ty_sel_qp_r"%string.
    destruct (repl_prefixes_sel H1) as [bs [He1 He2]].
    subst. assert (record_type (typ_rcd {A >: T <: T})) as Hrt by eauto.
    lets Hqbs: (pf_pt3_trans_inv_mult' _ Hi H Hp (or_intror Hrt)). apply* IHHv.
Qed.

Lemma invertible_typing_closure_tight_v: forall G v T U,
  inert G ->
  G ⊢//v v : T ->
  G ⊢# T <: U ->
  G ⊢//v v : U.
Proof.
  introv Hi HT Hsub.
  induction Hsub; auto.
  - dependent induction HT; eauto.
  - dependent induction HT. dependent induction H. inversion H.
  - destruct* (repl_andv Hi HT).
  - destruct* (repl_andv Hi HT).
  - dependent induction HT. dependent induction H. dependent induction H.
  - dependent induction HT. dependent induction H. dependent induction H.
  - pose proof (pt2_exists H0) as [? ?]. apply* replacement_repl_closure_pq3_v.
    (* repl closure for vals *)
  - pose proof (pt2_exists H0) as [? ?]. apply* replacement_repl_closure_qp3_v.
    (* repl closure for vals *)
  - apply* path_sel_repl_v.
  - apply* path_sel_repl_inv_v.
  - dependent induction HT; eauto.
Qed.

Lemma replacement_closure_v : forall G v T,
    inert G ->
    G ⊢# trm_val v : T ->
    G ⊢//v v : T.
Proof.
  introv Hi Hty.
  dependent induction Hty; eauto.
  specialize (IHHty v Hi eq_refl).
  apply* invertible_typing_closure_tight_v.
Qed.

Lemma repl_to_invertible_obj G U v :
  inert G ->
  G ⊢//v v : μ U ->
  exists U', G ⊢##v v : μ U' /\ G ⊢ U ⟿ U'.
Proof.
  intros Hi Hv. dependent induction Hv.
  - exists U. split*. constructor.
  - specialize (IHHv _ Hi eq_refl) as [U' [Hinv Hrc]].
    eexists. split.
    * eauto.
    * eapply star_trans. apply Hrc. apply star_one. econstructor. repeat eexists.
      apply H. eauto. eauto.
Qed.

Lemma repl_val_to_precise_lambda: forall G v S T,
    G ⊢//v v : ∀(S) T ->
    inert G ->
    exists L S' T',
      G ⊢!v v : ∀(S') T' /\
      G ⊢ S <: S' /\
      (forall y, y \notin L ->
                 G & y ~ S ⊢ open_typ y T' <: open_typ y T).
Proof.
  introv Ht Hg. dependent induction Ht.
  - apply invertible_val_to_precise_lambda; auto.
  - destruct (IHHt _ _ eq_refl Hg) as [L' [S' [T' [Hp [Hss Hst]]]]].
    exists (L \u L' \u dom G) S' T'. split. assumption. split. apply subtyp_trans with (T:=S1).
    apply* tight_to_general. assumption. intros.
    assert (ok (G & y ~ S)) as Hok by apply* ok_push.
    apply subtyp_trans with (T:=open_typ y T1).
    * eapply narrow_subtyping. apply* Hst. apply subenv_last. apply* tight_to_general. auto.
    * apply* H0.
Qed.


Require Import Arith List String.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Functor.
From CertiCoq.Plugin Require Import CertiCoq.

Import MonadNotation.
Open Scope monad_scope.
Open Scope string_scope.

Class IO_Types : Type :=
  { IO : Type -> Type }.

Class IO_Impl `{IO_Types} : Type :=
  { io_ret : forall (A : Type), A -> IO A
  ; io_bind : forall (A B : Type), IO A -> (A -> IO B) -> IO B
  }.

Instance IO_Monad `{IO_Impl} : Monad IO :=
  { ret  := io_ret
  ; bind := io_bind
  }.

Class StringFFI `{IO_Impl} : Type :=
  { print_string : string -> IO unit
  ; scan_string : IO string
  }.

Class Eq (A : Type) : Type :=
  { eqb : A -> A -> bool }.

Instance nat_eq : Eq nat :=
  {| eqb := Nat.eqb |}.

Instance string_eq : Eq string :=
  {| eqb := String.eqb |}.

Class Hashable (A : Type) : Type :=
  { hash : A -> nat }.

Instance hashable_nat : Hashable nat :=
  {| hash n := n |}.

Instance hashable_string : Hashable string :=
  {| hash s := String.length s |}.

Class Hash_Types : Type :=
  { HashTable : Type -> Type -> Type }.

Class HashFFI `{IO_Impl} `{Hash_Types} : Type :=
  { new    : forall {k v}, IO (HashTable k v)
  ; lookup : forall {k v} `{Eq k} `{Hashable k},
                HashTable k v -> k -> IO (option v)
  ; insert : forall {k v} `{Eq k} `{Hashable k},
                HashTable k v -> k -> v -> IO unit
  ; delete : forall {k v} `{Eq k} `{Hashable k},
                HashTable k v -> k -> IO unit
  }.

Definition prog
           `{IO_Types}
           `{@IO_Impl _}
           `{@StringFFI _ _}
           `{Hash_Types}
           `{@HashFFI _ _ _} : IO unit :=
  h <- new ;;
  insert h "Joomy" "Turkey" ;;
  insert h "Ana" "Ukraine" ;;
  insert h "Andrew" "USA" ;;

  let origin (k : string) :=
    v <- lookup h k ;;
    print_string (match v with
                  | None => "Couldn't find " ++ k
                  | Some v => k ++ " is from " ++ v
                  end) in

  origin "Joomy" ;;
  origin "Andrew".

CertiCoq FFI IO_Impl.
CertiCoq FFI StringFFI.
CertiCoq FFI HashFFI.
CertiCoq Compile -cps prog.


From iris.proofmode Require Import tactics.
From mwp.mwp_modalities Require Import mwp_step_fupd.
From mwp.mwp_modalities.ni_logrel Require Import mwp_left mwp_right ni_logrel_lemmas.
From logrel_ifc.lambda_sec Require Export lattice fundamental_binary notation.

Instance tpSecurityLattice : SecurityLattice tplabel := { ζ := L }.
Notation H := (LLabel H).
Notation L := (LLabel L).

(* This example showcases the interesting bit of an Amazon "lambda-service"
   where untrusted users have lambdas that may depend on some secrets (keys,
   environment variables, etc) and the functions get called sequentially.

   In a *termination-sensitive* setting, this example would not be
   noninterferent as [f] may leak secrets through termination. *)

(* f secret1 ;; g secret2 *)
Definition lambda_service : expr := (($1 $0) ;; ($3 $2))%E.

(* both fuctions take some (possibly secret) input and can make arbitrary side
   effects (e.g. writing the input to a ref with secret content) *)
Definition f_type τ := (TArrow L τ (TBool @ L)) @ L.

Section typed.

  Lemma lambda_typed τ1 τ2 :
    [τ1; f_type τ1; τ2; f_type τ2] # L ⊢ₜ lambda_service : TBool @ L.
  Proof.
    eapply Seq_typed.
    - eapply App_typed.
      + by apply Var_typed.
      + by apply Var_typed.
      + simpl. reflexivity.
      + by constructor.
    - eapply App_typed.
      + by apply Var_typed.
      + by apply Var_typed.
      + simpl. reflexivity.
      + by constructor.
  Qed.

End typed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Wellfounded.

Require Import bt env fun_defs.

Set Implicit Arguments.

Local Notation "e ⇢ x" := (@get_env _ _ e x).
Local Notation "e ⦃  x ⇠ v ⦄" := (@set_env _ _ Var_eq_dec e x v).

Section sorting.

  Variables (u x y z : Var) (Hxy : x <> y) (Hxz : x <> z) (Hyz : y <> z) (Hux : u <> x) (Huy : u <> y) (Huz : u <> z).

  Variable (p_split p_merge p_merge_sort p_cmp p_leq p_msort : Fun).

  Variable (param : Fun -> Var)
           (body : Fun -> fun_expr).

  Notation "f // s ~~> v" := (fun_sem param body f s v).

  Definition fe_cmp :=
    MATCH £u WITH
        ø   ⇒ ø
     OR x#y ⇒ MATCH £x WITH
          ø   ⇒ MATCH £y WITH
            ø   ⇒ ø
         OR x#x ⇒ ø#ø
       OR u#x ⇒ MATCH £y WITH
            ø   ⇒ ø#(ø#ø)
         OR z#y ⇒ MATCH CALL p_cmp ON (£u#£z) WITH
              ø   ⇒ CALL p_cmp ON (£x#£y)
           OR u#x ⇒ £u#£x.

  Hypothesis (Hparam_cmp : param p_cmp = u) (Hbody_cmp : body p_cmp = fe_cmp).

  Fact fe_cmp_spec f e a b : f // e ~~> ⟨a,b⟩ -> CALL p_cmp ON f // e ~~> bt_compare a b.
  Proof.
    revert b e f; induction a as [ | a1 H1 a2 H2 ]; intros [ | b1 b2 ] e f H;
      constructor 7 with (1 := H); rewrite Hbody_cmp, Hparam_cmp; unfold fe_cmp.
    + constructor 5 with ω ω.
      1: apply fs_var; rew env.
      constructor 4.
      1: apply fs_var; rew env.
      constructor 4.
      1: apply fs_var; rew env.
      constructor 2.
    + constructor 5 with ω ⟨b1,b2⟩.
      1: apply fs_var; rew env.
      constructor 4.
      1: apply fs_var; rew env.
      constructor 5 with b1 b2.
      1: apply fs_var; rew env.
      constructor 3; constructor 2.
    + constructor 5 with ⟨a1,a2⟩ ω.
      1: apply fs_var; rew env.
      constructor 5 with a1 a2.
      1: apply fs_var; rew env.
      constructor 4.
      1: apply fs_var; rew env.
      repeat constructor 3; constructor 2.
    + constructor 5 with ⟨a1,a2⟩ ⟨b1,b2⟩.
      1: apply fs_var; rew env.
      constructor 5 with a1 a2.
      1: apply fs_var; rew env.
      constructor 5 with b1 b2.
      1: apply fs_var; rew env.
      match goal with |- _ // ?e ~~> _ => set (e' := e) end.
      specialize (H1 b1 e' (£u#£z)).
      simpl.
      destruct (bt_compare a1 b1) as [ | x1 x2 ].
      * constructor 4.
        1: apply H1; unfold e'; constructor 3; apply fs_var; rew env.
        apply H2; constructor 3; unfold e'; apply fs_var; rew env.
      * constructor 5 with x1 x2.
        1:apply H1; unfold e'; constructor 3; apply fs_var; rew env.
        constructor 3; apply fs_var; rew env.
  Qed.

  Definition fe_leq :=
    MATCH CALL p_cmp ON £u WITH
        ø   ⇒ ø#ø
     OR x#x ⇒ MATCH £x WITH
          ø   ⇒ ø#ø
       OR x#x ⇒ ø.

  Hypothesis (Hparam_leq : param p_leq = u) (Hbody_leq : body p_leq = fe_leq).

  Fact fe_leq_spec f e a b : f // e ~~> ⟨a,b⟩ -> CALL p_leq ON f // e ~~> bt_leq a b.
  Proof.
    intros H.
    constructor 7 with (1 := H); rewrite Hbody_leq, Hparam_leq; unfold fe_leq.
    generalize (@fe_cmp_spec £u (e⦃u⇠⟨a,b⟩⦄) a b) (bt_compare_3 a b).
    unfold bt_leq.
    intros H1 [ H2 | [ H2 | H2 ] ].
    + constructor 4.
      * rewrite <- H2; apply H1, fs_var; rew env.
      * rewrite H2; constructor 3; constructor 2.
    + constructor 5 with ω ω.
      * rewrite <- H2; apply H1, fs_var; rew env.
      * constructor 4.
        1: apply fs_var; rew env.
        rewrite H2; constructor 3; constructor 2.
    + constructor 5 with ω ⟨ω,ω⟩.
      * rewrite <- H2.
        apply fe_cmp_spec, fs_var; rew env.
      * rewrite H2.
        constructor 5 with ω ω.
        1: apply fs_var; rew env.
        constructor 2.
  Qed.

  Definition fe_split :=
    MATCH £u WITH
        ø   ⇒ ø#ø
     OR x#u ⇒ MATCH £u WITH
          ø   ⇒ (£x#ø)#ø
       OR y#u ⇒ MATCH CALL p_split ON £u WITH
            ø   ⇒ ø#ø
         OR u#z ⇒ (£x#£u)#(£y#£z).

  Hypothesis (Hparam_split : param p_split = u) (Hbody_split : body p_split = fe_split).

  Fact fe_split_spec f e l : f // e ~~> l -> CALL p_split ON f // e ~~> bt_split l.
  Proof.
    revert f e.
    induction on l as IHl with measure (bt_length l); intros f e H.
    constructor 7 with (1 := H); rewrite Hbody_split, Hparam_split; unfold fe_split.
    destruct l as [ | t1 [ | t2 l ] ].
    + constructor 4.
      1: apply fs_var; rew env.
      simpl; constructor 3; constructor 2.
    + constructor 5 with t1 ω.
      1: apply fs_var; rew env.
      simpl; constructor 4.
      1: apply fs_var; rew env.
      repeat constructor 3; try constructor 2.
      apply fs_var; rew env.
    + constructor 5 with t1 ⟨t2,l⟩.
      1: apply fs_var; rew env.
      constructor 5 with t2 l.
      1: apply fs_var; rew env.
      specialize (IHl l); simpl.
      destruct (bt_split l) as [ | l1 l2 ].
      * constructor 4.
        - apply IHl; simpl; try lia.
          apply fs_var; rew env.
        - constructor 3; constructor 2.
      * constructor 5 with l1 l2.
        - apply IHl; simpl; try lia.
          apply fs_var; rew env.
        - constructor 3; constructor 3; apply fs_var; rew env.
  Qed.

  Variable (v x1 y1 : Var)
           (Huv : u <> v)   (Hxv : x <> v)   (Hvx1 : v <> x1)
           (Hxy1 : x <> y1) (Hxx1 : x <> x1) (Hux1 : u <> x1)
           (Hyy1 : y <> y1) (Huy1 : u <> y1) (Hx1y1 : x1 <> y1)
           (Hyx1 : x1 <> y) (Hyv : v <> y)   (Hvy1 : v <> y1).

  Definition fe_merge :=
     MATCH £u WITH
        ø   ⇒ ø
     OR u#v ⇒ MATCH £u WITH
          ø    ⇒ £v
       OR x#x1 ⇒ MATCH £v WITH
            ø    ⇒ £u
         OR y#y1 ⇒ MATCH CALL p_leq ON (£x#£y) WITH
                ø   ⇒ £y#CALL p_merge ON (£u#£y1)
             OR u#u ⇒ £x#CALL p_merge ON (£x1#£v).

  Hypothesis (Hparam_merge : param p_merge = u) (Hbody_merge : body p_merge = fe_merge).

  Fact fe_merge_spec_ind f e l m p : f // e ~~> ⟨l,m⟩ -> l ⊕ m ⊳ p -> CALL p_merge ON f // e ~~> p.
  Proof.
    intros H1 H2; revert H2 f e H1.
    induction 1 as [ m | l | r s l m p H1 H2 IH2 | r s l m p H1 H2 IH2 ]; intros f e H;
      constructor 7 with (1 := H);
      rewrite Hbody_merge, Hparam_merge; unfold fe_merge.
    + constructor 5 with ω m.
      1: apply fs_var; rew env.
      constructor 4; apply fs_var; rew env.
    + constructor 5 with l ω.
      1: apply fs_var; rew env.
      destruct l as [ | a b ].
      * constructor 4; apply fs_var; rew env.
      * constructor 5 with a b.
        1: apply fs_var; rew env.
        constructor 4; apply fs_var; rew env.
    + constructor 5 with ⟨r,l⟩ ⟨s,m⟩.
      1: apply fs_var; rew env.
      constructor 5 with r l.
      1: apply fs_var; rew env.
      constructor 5 with s m.
      1: apply fs_var; rew env.
      constructor 4.
      1: rewrite <- H1; apply fe_leq_spec; constructor 3; apply fs_var; rew env.
      constructor 3.
      1: apply fs_var; rew env.
      apply IH2.
      constructor 3; apply fs_var; rew env.
    + constructor 5 with ⟨r,l⟩ ⟨s,m⟩.
      1: apply fs_var; rew env.
      constructor 5 with r l.
      1: apply fs_var; rew env.
      constructor 5 with s m.
      1: apply fs_var; rew env.
      case_eq (bt_leq r s).
      1: intro; destruct H1; auto.
      intros a b E.
      constructor 5 with a b.
      1: rewrite <- E; apply fe_leq_spec; constructor 3; apply fs_var; rew env.
      constructor 3.
      1: apply fs_var; rew env.
      apply IH2.
      constructor 3; apply fs_var; rew env.
  Qed.

  Fact fe_merge_spec f e l m : f // e ~~> ⟨l,m⟩ -> CALL p_merge ON f // e ~~> bt_merge l m.
  Proof.
    intros H; apply fe_merge_spec_ind with (1 := H), bt_merge_spec.
  Qed.

  Definition fe_msort :=
    MATCH £u WITH
        ø   ⇒ ø
     OR x#v ⇒ MATCH £v WITH
          ø   ⇒ £u
       OR x#x ⇒ MATCH CALL p_split ON £u WITH
            ø   ⇒ ø
         OR x#y ⇒ CALL p_merge ON (CALL p_msort ON £x#CALL p_msort ON £y).

  Hypothesis (Hparam_msort : param p_msort = u) (Hbody_msort : body p_msort = fe_msort).

  Fact fe_msort_spec_ind f e l p : f // e ~~> l -> l ⋗ p -> CALL p_msort ON f // e ~~> p.
  Proof.
    intros H1 H2; revert H2 f e H1.
    induction 1 as [ | t | l l1 l2 m1 m2 p H1 H2 H3 IH3 H4 IH4 H5 ]; intros f e H;
      constructor 7 with (1 := H);
      rewrite Hbody_msort, Hparam_msort; unfold fe_msort.
    + constructor 4.
      1: apply fs_var; rew env.
      constructor 2.
    + constructor 5 with t ω.
      1: apply fs_var; rew env.
      constructor 4; apply fs_var; rew env.
    + case_eq l.
      1: { intros ?; subst l; simpl in H1; lia. }
      intros t1 [ | t2 m ] E.
      1: { subst l; simpl in H1; lia. }
      constructor 5 with t1 ⟨t2,m⟩.
      1: apply fs_var; rew env.
      constructor 5 with t2 m.
      1: apply fs_var; rew env.
      rewrite <- E.
      constructor 5 with l1 l2.
      * rewrite <- H2; apply fe_split_spec.
        apply fs_var; rew env.
      * apply fe_merge_spec_ind with m1 m2; auto.
        - constructor 3.
          ++ apply IH3, fs_var; rew env.
          ++ apply IH4, fs_var; rew env.
  Qed.

  Fact fe_msort_spec f e l : f // e ~~> l -> CALL p_msort ON f // e ~~> bt_msort l.
  Proof. intros H; apply fe_msort_spec_ind with (1 := H), bt_msort_spec. Qed.

End sorting.


From Equations Require Import Equations.
Require Import Coq.Program.Equality.

Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FirstOrderConfRelSimplified.
Require Import Leapfrog.Ntuple.
Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.
Import HListNotations.

Set Universe Polymorphism.

Section CompileConfRelSimplified.
  Set Implicit Arguments.
  (* State identifiers. *)
  Variable (St: Type).
  Context `{St_eq_dec: EquivDec.EqDec St eq}.
  Context `{St_finite: @Finite St _ St_eq_dec}.

  (* Header identifiers. *)
  Variable (Hdr: Type).
  Context `{Hdr_eq_dec: EquivDec.EqDec Hdr eq}.
  Context `{Hdr_finite: @Finite Hdr _ Hdr_eq_dec}.
  Variable (Hdr_sz: Hdr -> nat).

  Variable (a: P4A.t St Hdr_sz).

  Fixpoint compile_bctx (b: bctx): ctx (sig Hdr_sz) :=
    match b with
    | BCEmp => SLNil _
    | BCSnoc b size => Snoc _ (compile_bctx b) (Bits size)
    end.

  Definition be_sort {c} b1 b2 (e: bit_expr Hdr c) : sorts :=
    Bits (be_size Hdr_sz b1 b2 e).

  Equations compile_var {c: bctx} (x: bvar c) : var (sig Hdr_sz) (compile_bctx c) (Bits (check_bvar x)) :=
    { compile_var (BVarTop c size) :=
        VHere _ (compile_bctx c) (Bits (check_bvar (BVarTop c size)));
      compile_var (BVarRest y) :=
        VThere _ (compile_bctx _) _ (Bits (check_bvar y)) (compile_var y) }.

  Equations compile_bval (c: bctx) (v: bval c) : valu _ (fm_model a) (compile_bctx c) by struct c := {
    compile_bval BCEmp _ := VEmp _ _;
    compile_bval (BCSnoc c' n) (v', x) := VSnoc _ (fm_model a) (Bits n) _ (compile_bval c' v') x;
  }.

  Arguments compile_bval {_} _.

  Equations decompile_val (c: bctx) (v: valu _ (fm_model a) (compile_bctx c)) : bval c by struct c := {
      decompile_val BCEmp _ := tt;
      decompile_val (BCSnoc c' n) (VSnoc _ _ _ _ v' x) := (decompile_val c' v', x);
  }.
  Arguments decompile_val {_} _.

  Lemma bval_roundtrip:
    forall {c: bctx} (valu: _ (fm_model a) (compile_bctx c)),
      compile_bval (decompile_val valu) = valu.
  Proof.
    intros.
    induction c.
    - simpl.
      dependent destruction valu.
      trivial.
    - dependent destruction valu.
      autorewrite with decompile_val.
      autorewrite with compile_bval.
      erewrite IHc.
      trivial.
  Qed.

  Definition outer_ctx b1 b2 : ctx (sig Hdr_sz) :=
    Snoc _ (
      Snoc _ (
        Snoc _ (
          Snoc _ (SLNil _) Store
        ) Store
      ) (Bits b2)
    ) (Bits b1).

  Definition var_buf1 b1 b2 : var (sig Hdr_sz) (outer_ctx b1 b2) (Bits b1) :=
    VHere (sig Hdr_sz) _ _.

  Definition var_buf2 b1 b2 : var (sig Hdr_sz) (outer_ctx b1 b2) (Bits b2) :=
    VThere (sig Hdr_sz) _ _ _ (VHere (sig Hdr_sz) _ _).

  Definition var_store1 b1 b2 : var (sig Hdr_sz) (outer_ctx b1 b2) Store :=
    VThere (sig Hdr_sz) _ _ _ (VThere (sig Hdr_sz) _ _ _ (VHere (sig Hdr_sz) _ _)).

  Definition var_store2 b1 b2 : var (sig Hdr_sz) (outer_ctx b1 b2) Store :=
    VThere (sig Hdr_sz) _ _ _ (VThere (sig Hdr_sz) _ _ _ (
    VThere (sig Hdr_sz) _ _ _ (VHere (sig Hdr_sz) _ _))).

  Definition outer_valu {b1 b2} buf1 buf2 store1 store2 :=
    VSnoc _ (fm_model a) (Bits b1) _ (
      VSnoc _ (fm_model a) (Bits b2) _ (
        VSnoc _ (fm_model a) Store _ (
          VSnoc _ (fm_model a) Store _ (VEmp _ _) store2)
        store1)
      buf2)
    buf1.

  Equations compile_bit_expr
            {c: bctx}
            (b1 b2: nat)
            (e: bit_expr Hdr c)
    : tm (sig Hdr_sz) (app_ctx (outer_ctx b1 b2) (compile_bctx c)) (be_sort b1 b2 e) :=
    { compile_bit_expr b1 b2 (BELit _ _ l) :=
        TFun (sig Hdr_sz) (BitsLit _ (List.length l) (Ntuple.l2t l)) hnil;
      compile_bit_expr b1 b2 (BEBuf _ _ Left) :=
        TVar (weaken_var _ (var_buf1 b1 b2));
      compile_bit_expr b1 b2 (BEBuf _ _ Right) :=
        TVar (weaken_var _ (var_buf2 b1 b2));
      compile_bit_expr b1 b2 (BEHdr _ Left (P4A.HRVar h)) :=
        TFun (sig Hdr_sz) (Lookup _ h)
             (TVar (weaken_var _ (var_store1 b1 b2)) ::: hnil);
      compile_bit_expr b1 b2 (BEHdr _ Right (P4A.HRVar h)) :=
        TFun (sig Hdr_sz) (Lookup _ h)
             (TVar (weaken_var _ (var_store2 b1 b2)) ::: hnil);
      compile_bit_expr b1 b2 (BEVar _ b) :=
        TVar (reindex_var (compile_var b));
      compile_bit_expr b1 b2 (BESlice e hi lo) :=
        TFun (sig Hdr_sz) (Slice _ _ hi lo)
             (compile_bit_expr b1 b2 e ::: hnil);
      compile_bit_expr b1 b2 (BEConcat e1 e2) :=
      simplify_concat_zero (
        TFun (sig Hdr_sz) (Concat _ _ _)
             (compile_bit_expr b1 b2 e1 :::
              compile_bit_expr b1 b2 e2 ::: hnil)) }.

  Equations compile_store_rel
            {c: bctx}
            (b1 b2: nat)
            (r: store_rel Hdr c)
            : fm (sig Hdr_sz) (app_ctx (outer_ctx b1 b2) (compile_bctx c)) :=
    { compile_store_rel b1 b2 BRTrue := FTrue;
      compile_store_rel b1 b2 BRFalse := FFalse;
      compile_store_rel b1 b2 (BREq e1 e2) :=
        match eq_dec (be_size Hdr_sz b1 b2 e1) (be_size Hdr_sz b1 b2 e2) with
        | left Heq =>
          FEq (eq_rect _ (fun n => tm (sig Hdr_sz) _ (Bits n))
                       (simplify_concat_zero (compile_bit_expr b1 b2 e1)) _ Heq)
              (simplify_concat_zero (compile_bit_expr b1 b2 e2))
        | right _ => FFalse
        end;
      compile_store_rel b1 b2 (BRAnd r1 r2) :=
        FAnd _ (compile_store_rel b1 b2 r1)
               (compile_store_rel b1 b2 r2);
      compile_store_rel b1 b2 (BROr r1 r2) :=
        FOr _ (compile_store_rel b1 b2 r1)
              (compile_store_rel b1 b2 r2);
      compile_store_rel b1 b2 (BRImpl r1 r2) :=
        FImpl (compile_store_rel b1 b2 r1)
              (compile_store_rel b1 b2 r2)
    }.

  Definition compile_simplified_conf_rel
    (b1 b2: nat)
    (r: simplified_conf_rel Hdr)
    : fm (sig Hdr_sz) (outer_ctx b1 b2)
  :=
    let sr: fm (sig Hdr_sz) _ :=
        compile_store_rel b1 b2 (projT2 r)
    in
    quantify _ sr.

  Definition compile_simplified_crel
    (b1 b2: nat)
    (R: simplified_crel Hdr)
    : fm (sig Hdr_sz) (outer_ctx b1 b2) :=
    List.fold_right (fun r f =>
      FAnd _ (compile_simplified_conf_rel b1 b2 r) f
    ) FTrue R.

  (* Compilation from simplified entailments to FOL(Conf). *)
  Definition compile_simplified_entailment
    (se: simplified_entailment a)
    : fm (sig Hdr_sz) (SLNil _) :=
    quantify_all _
      (FImpl (compile_simplified_crel
               se.(se_st).(cs_st1).(st_buf_len)
               se.(se_st).(cs_st2).(st_buf_len)
               se.(se_prems))
             (compile_simplified_conf_rel
               se.(se_st).(cs_st1).(st_buf_len)
               se.(se_st).(cs_st2).(st_buf_len)
               se.(se_concl))).

  (* Compilation from simplified co-entailments to FOL(Conf). *)
  Definition compile_simplified_entailment'
    (se: simplified_entailment a)
    : fm (sig Hdr_sz) (SLNil _) :=

    quantify_all _
      (FImpl (compile_simplified_conf_rel
               se.(se_st).(cs_st1).(st_buf_len)
               se.(se_st).(cs_st2).(st_buf_len)
               se.(se_concl))
             (compile_simplified_crel
               se.(se_st).(cs_st1).(st_buf_len)
               se.(se_st).(cs_st2).(st_buf_len)
               se.(se_prems))).

  Lemma compile_bvar_correct:
    forall c bval (b: bvar c),
      interp_bvar bval b =
      find (sig Hdr_sz) (fm_model a) (compile_var b) (compile_bval bval).
  Proof.
    induction c; intros.
    - dependent destruction b.
    - destruct bval.
      dependent destruction b;
      autorewrite with interp_bvar; auto.
      now rewrite IHc.
  Qed.

  Lemma compile_bit_expr_correct:
    forall c (e: bit_expr Hdr c) bval b1 b2 buf1 buf2 store1 store2,
      interp_bit_expr e bval buf1 buf2 store1 store2 =
      let valu := outer_valu buf1 buf2 store1 store2 in
      interp_tm (m := fm_model a) (app_valu _ valu (compile_bval bval))
                (compile_bit_expr b1 b2 e).
  Proof.
    intros; simpl.
    induction e; try destruct a0; try destruct h;
    autorewrite with interp_bit_expr;
    autorewrite with compile_bit_expr;
    autorewrite with interp_tm; auto.
    - now rewrite find_app_left.
    - now rewrite find_app_left.
    - simpl; autorewrite with mod_fns.
      now rewrite find_app_left.
    - simpl; autorewrite with mod_fns.
      now rewrite find_app_left.
    - rewrite find_app_right.
      apply compile_bvar_correct.
    - now rewrite IHe.
    - rewrite IHe1, IHe2.
      now erewrite <- simplify_concat_zero_corr by typeclasses eauto.
  Qed.

  Lemma compile_store_rel_correct:
    forall c (r: store_rel Hdr c) bval b1 b2 buf1 buf2 store1 store2,
      interp_store_rel r bval buf1 buf2 store1 store2 <->
      let valu := outer_valu buf1 buf2 store1 store2 in
      interp_fm (m := fm_model a) (app_valu _ valu (compile_bval bval))
                (compile_store_rel b1 b2 r).
  Proof.
    intros; simpl.
    induction r;
    autorewrite with interp_store_rel;
    autorewrite with compile_store_rel;
    try destruct (eq_dec _ _);
    autorewrite with interp_fm;
    try tauto.
    rewrite <- interp_tm_rect.
    repeat erewrite <- simplify_concat_zero_corr by typeclasses eauto.
    repeat rewrite compile_bit_expr_correct; simpl.
    intuition.
  Qed.

  Lemma compile_simplified_conf_rel_correct:
    forall r b1 b2 buf1 buf2 store1 store2,
      interp_simplified_conf_rel r buf1 buf2 store1 store2 <->
      interp_fm (m := fm_model a) (outer_valu buf1 buf2 store1 store2)
                (compile_simplified_conf_rel b1 b2 r).
  Proof.
    intros; destruct r.
    unfold interp_simplified_conf_rel, compile_simplified_conf_rel.
    rewrite quantify_correct; simpl.
    setoid_rewrite compile_store_rel_correct; simpl.
    split; intros; auto.
    now rewrite <- bval_roundtrip with (valu := valu).
  Qed.

  Lemma compile_simplified_crel_correct:
    forall r b1 b2 buf1 buf2 store1 store2,
      interp_simplified_crel r buf1 buf2 store1 store2 <->
      interp_fm (m := fm_model a) (outer_valu buf1 buf2 store1 store2)
                (compile_simplified_crel b1 b2 r).
  Proof.
    intros.
    induction r;
    autorewrite with interp_simplified_crel; simpl;
    autorewrite with interp_fm.
    - intuition.
    - now rewrite compile_simplified_conf_rel_correct, IHr.
  Qed.

  Transparent interp_fm.

  (* Correctness of compilation from simplified entailments to FOL(Conf). *)
  Lemma compile_simplified_entailment_correct:
      forall i e,
        interp_simplified_entailment i e <->
        (state_template_sane e.(se_st).(cs_st1) ->
         state_template_sane e.(se_st).(cs_st2) ->
         i e.(se_st).(cs_st1) e.(se_st).(cs_st2) ->
         interp_fm (m := fm_model a) (VEmp _ _)
                   (compile_simplified_entailment e)
        ).
  Proof.
    intros.
    destruct e.
    unfold interp_simplified_entailment; simpl.
    unfold compile_simplified_entailment; simpl.
    rewrite quantify_all_correct; simpl.
    setoid_rewrite compile_simplified_crel_correct.
    setoid_rewrite compile_simplified_conf_rel_correct.
    intuition.
    unfold outer_ctx in valu.
    repeat dependent destruction valu.
    simpl in *.
    eauto.
  Qed.

  (* Correctness of compilation from simplified co-entailments to FOL(Conf). *)
  Lemma compile_simplified_entailment_correct':
      forall i e,
        interp_simplified_entailment' i e <->
        (state_template_sane e.(se_st).(cs_st1) ->
         state_template_sane e.(se_st).(cs_st2) ->
         i e.(se_st).(cs_st1) e.(se_st).(cs_st2) ->
         interp_fm (m := fm_model a) (VEmp _ _)
                   (compile_simplified_entailment' e)).
  Proof.
    intros; destruct e; simpl.
    unfold interp_simplified_entailment'; simpl.
    unfold compile_simplified_entailment'; simpl.
    rewrite quantify_all_correct; simpl.
    setoid_rewrite compile_simplified_conf_rel_correct.
    setoid_rewrite compile_simplified_crel_correct.
    intuition.
    unfold outer_ctx in valu.
    repeat dependent destruction valu.
    simpl in *.
    eauto.
  Qed.

  Opaque interp_fm.

End CompileConfRelSimplified.


Require Import ExtLib.Data.Positive.
Require Import mc_reify.funcs.
Require Import mc_reify.typ_eq.
Require Import mc_reify.statement_eq.
Require Import Coq.Arith.EqNat.
Require Import mc_reify.clight_expr_eq.
Require Import mc_reify.list_ctype_eq.
Require Import mc_reify.list_efield_eq.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.List.
Require Import ExtLib.Core.RelDec.

Fixpoint ptree_cmp {T : Type} (p1 p2: Maps.PTree.tree T)
         (e : T -> T -> bool) :=
match p1, p2 with
| Maps.PTree.Leaf, Maps.PTree.Leaf => true
| Maps.PTree.Node l1 i1 r1, Maps.PTree.Node l2 i2 r2 =>
  match i1, i2 with
    | Some v1, Some v2 => andb (e v1 v2)
                               (andb (ptree_cmp l1 l2 e)
                                     (ptree_cmp r1 r2 e))
    | None, None => (andb (ptree_cmp l1 l2 e)
                          (ptree_cmp r1 r2 e))
    | _, _ => false
  end
| _, _ => false
end.

Lemma ptree_cmp_sound : forall T p1 p2 e,
(forall (i1 i2 : T), e i1 i2 = true -> i1 = i2) ->
ptree_cmp p1 p2 e = true ->
p1 = p2.
Proof.
intros.
generalize dependent p2. induction p1; intros; destruct p2; auto;
simpl in *; try congruence.
destruct o, o0. simpl in *.
consider (e t t0); intros. specialize (H _ _ H0).
 subst.
consider (ptree_cmp p1_1 p2_1 e); intros.
apply IHp1_1 in H. apply IHp1_2 in H1. subst.
auto.
simpl in *; congruence.
simpl in *; congruence.
congruence. congruence.
consider (ptree_cmp p1_1 p2_1 e); intros.
apply IHp1_1 in H0. apply IHp1_2 in H1.
subst; auto.
simpl in *; congruence.
Qed.

Definition const_beq a b :=
match a, b with
| fN c1, fN c2 => beq_nat c1 c2
| fZ c1, fZ c2 => Zbool.Zeq_bool c1 c2
| fPos c1, fPos c2 =>  BinPos.Pos.eqb c1 c2
| fCtype c1, fCtype c2 => expr.eqb_type c1 c2
| fCexpr c1, fCexpr c2 => expr_beq c1 c2
| fenv c1, fenv c2 => ptree_cmp c1 c2 expr.eqb_type
| fllrr c1, fllrr c2 => match c1, c2 with | efield_lemmas.LLLL, efield_lemmas.LLLL | efield_lemmas.RRRR, efield_lemmas.RRRR => true | _, _ => false end
| _, _ => false
end.

Instance const_rel_dec : RelDec (@eq const) := { rel_dec := const_beq }.

Definition beq_z_true : forall a b, Zbool.Zeq_bool a b = true -> a = b.
Proof.
intros. apply Zbool.Zeq_bool_eq in H. subst.
auto.
Qed.

Hint Resolve beq_nat_true : expr_beq.
Hint Resolve beq_z_true : expr_beq.

Lemma const_beq_sound : forall a b, const_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
+ eapply ptree_cmp_sound; [| exact H].
  intros; solve_expr_beq_sound.
+ destruct l, l0; try inversion H; reflexivity.
Qed.

Hint Resolve const_beq_sound : expr_beq.

Definition z_op_beq a b : bool :=
match a, b with
| fZ_lt, fZ_lt
| fZ_le, fZ_le
| fZ_gt, fZ_gt
| fZ_ge, fZ_ge
| fZ_add, fZ_add
| fZ_sub, fZ_sub
| fZ_mul, fZ_mul
| fZ_div, fZ_div
| fZ_mod, fZ_mod
| fZ_land, fZ_land
| fZ_max, fZ_max
| fZ_opp, fZ_opp  => true
| _, _ => false
end.

Hint Resolve beq_nat_true : expr_beq.

Lemma z_op_beq_sound : forall a b, z_op_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve z_op_beq_sound : expr_beq.

Definition int_op_beq a b : bool :=
match a, b with
| fint_add, fint_add
| fint_and, fint_and
| fint_lt, fint_lt
| fint_ltu, fint_ltu
| fint_mul, fint_mul
| fint_neg, fint_neg
| fint_sub, fint_sub
| fint_cmp, fint_cmp
| fint_cmpu, fint_cmpu
| fint_repr, fint_repr
| fint_signed, fint_signed
| fint_unsigned, fint_unsigned
| fint_max_unsigned, fint_max_unsigned
| fint64_repr, fint64_repr => true
| _, _ => false
end.

Lemma int_op_beq_sound : forall a b, int_op_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve int_op_beq_sound : expr_beq.

Definition values_beq a b:=
match a, b with
| fVint, fVint
| fVfloat, fVfloat
| fVlong, fVlong
| fVptr, fVptr
| fVundef, fVundef => true
| _, _ => false
end.

Lemma values_beq_sound : forall a b, values_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve values_beq_sound : expr_beq.

Definition eval_beq a b :=
match a,b with
| feval_cast t1_1 t2_1 , feval_cast t1_2 t2_2 => andb (expr.eqb_type t1_1 t1_2)
                                                      (expr.eqb_type t2_1 t2_2)
| fderef_noload t1, fderef_noload t2 => expr.eqb_type t1 t2
| feval_field t1 id1 , feval_field t2 id2 =>  andb (expr.eqb_type t1 t2)
                                                   (BinPos.Pos.eqb id1 id2)
| feval_binop op1 t1_1 t2_1, feval_binop op2 t1_2 t2_2 =>
              andb (andb (binary_op_beq op1 op2)
                   (expr.eqb_type t1_1 t1_2))
                   (expr.eqb_type t2_1 t2_2)
| feval_unop op1 t1 , feval_unop op2 t2 =>
              andb (unary_op_beq op1 op2)
                   (expr.eqb_type t1 t2)
| feval_id id1, feval_id id2 => BinPos.Pos.eqb id1 id2
| _, _ => false
end.

Lemma eval_beq_sound : forall a b, eval_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve eval_beq_sound : expr_beq.

Definition other_beq a b :=
match a, b with
| ftwo_power_nat, ftwo_power_nat
| fforce_ptr, fforce_ptr
| fand, fand
| falign, falign
| ftyped_true, ftyped_true => true
| fnone t1, fnone t2
| fsome t1, fsome t2
| feq t1, feq t2 => typ_beq t1 t2
| _, _ => false
end
.

Hint Resolve typ_beq_sound : expr_beq.

Lemma other_beq_sound : forall a b, other_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve other_beq_sound : expr_beq.

Definition data_beq a b :=
match a, b with
| fnil t1, fnil t2
| fcons t1, fcons t2
| fappend t1, fappend t2 => typ_beq t1 t2
| fnth_error t1 n1, fnth_error t2 n2
| freplace_nth t1 n1, freplace_nth t2 n2 => andb (beq_nat n1 n2) (typ_beq t1 t2)
| fmap ta1 tb1, fmap ta2 tb2
| ffold_right ta1 tb1, ffold_right ta2 tb2
| ffold_left ta1 tb1, ffold_left ta2 tb2 => andb (typ_beq ta1 ta2) (typ_beq tb1 tb2)
| fleaf t, fleaf t'
| fnode t, fnode t'
| fempty t, fempty t' => typ_beq t t'
| _ , _ => false
end.

Lemma data_beq_sound : forall a b, data_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve data_beq_sound : expr_beq.

Definition sep_beq a b :=
match a, b with
| flocal, flocal
| fprop, fprop => true
| fdata_at ty1, fdata_at ty2 => expr.eqb_type ty1 ty2
| fproj_val ty1, fproj_val ty2 => expr.eqb_type ty1 ty2
| fupd_val ty1, fupd_val ty2 => expr.eqb_type ty1 ty2
(*| ffield_at ty1 li1, ffield_at ty2 li2 => andb (expr.eqb_type ty1 ty2)
                                               (li1 ?[eq] li2)
| flseg t1 i1 _, flseg t2 i2 _ => andb (expr.eqb_type t1 t2) (BinPos.Pos.eqb i1 i2)*)
| _, _ => false
end
.

Lemma sep_beq_sound : forall a b, sep_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed. (*
rewrite (rel_dec_correct) in H0. auto.
assert (t = t0) by auto with expr_beq.
assert (i = i0) by auto with expr_beq.
assert (X := types.listspec_ext). subst.
 specialize (X t0 i0 l l0).
subst; auto.
Qed. *)

Hint Resolve sep_beq_sound : expr_beq.

Definition type_bool_eq (a b : Ctypes.type * bool) :=
match a, b with
| (t1, b1), (t2, b2) => andb (expr.eqb_type t1 t2)
                             match b1, b2 with
                               | true, true | false, false => true
                               | _, _ => false
                             end
end.

Definition type_bool_eq_sound : forall a b,
type_bool_eq a b = true-> a = b.
intros. destruct a, b.
solve_expr_beq_sound.
destruct b, b0; simpl in H0; congruence.
Qed.

Definition smx_beq a b :=
match a, b with
| fsemax, fsemax
| fnormal_ret_assert, fnormal_ret_assert
| fassertD, fassertD => true
| flocalD , flocalD => true
| fstatement s1, fstatement s2 => statement_beq s1 s2
| ftycontext t1 l1 r1 gt1, ftycontext t2 l2 r2 gt2  =>
  andb (ptree_cmp t1 t2 type_bool_eq)
       (andb (ptree_cmp l1 l2 expr.eqb_type)
             (andb (expr.eqb_type r1 r2)
                   (ptree_cmp gt1 gt2 expr.eqb_type)))
| flater, flater => true
| flater_lift, flater_lift => true
| fnested_field_type2, fnested_field_type2 => true
| fis_neutral_cast, fis_neutral_cast => true
| fmsubst_efield_denote efs1, fmsubst_efield_denote efs2 => list_eqb RelDec_efield_beq efs1 efs2
| flegal_nested_efield tts1, flegal_nested_efield tts2 => list_eqb RelDec_ctype_beq tts1 tts2
| fmsubst_eval_LR, fmsubst_eval_LR => true
| ftc_LR_b_norho, ftc_LR_b_norho => true
| ftc_environ, ftc_environ => true
| ftc_efield_b_norho efs1, ftc_efield_b_norho efs2 => list_eqb RelDec_efield_beq efs1 efs2
| fnested_efield, fnested_efield => true
| ftypeof_temp, ftypeof_temp => true
| ftc_val, ftc_val => true
| flegal_nested_field, flegal_nested_field => true
| fstruct_field, fstruct_field => true
| funion_field, funion_field => true
| farray_subsc, farray_subsc => true
| fwritable_share, fwritable_share => true
| fTsh, fTsh => true
| fEws, fEws => true
| ftype_is_by_value, ftype_is_by_value => true
| _, _ => false
end.

Hint Resolve statement_beq_sound : expr_beq.

Lemma smx_beq_sound : forall a b, smx_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
apply ptree_cmp_sound in H; auto.
intros. apply type_bool_eq_sound in H3. auto.
apply ptree_cmp_sound in H0;
solve_expr_beq_sound.
apply ptree_cmp_sound in H2;
solve_expr_beq_sound.
Qed.

Hint Resolve smx_beq_sound : expr_beq.

Definition func_beq a b :=
match a, b with
| Const f1, Const f2 => const_beq f1 f2
| Zop f1, Zop f2 => z_op_beq f1 f2
| Intop f1, Intop f2 => int_op_beq f1 f2
| Value f1, Value f2 => values_beq f1 f2
| Eval_f f1, Eval_f f2 => eval_beq f1 f2
| Other f1, Other f2 => other_beq f1 f2
| Sep f1, Sep f2 => sep_beq f1 f2
| Data f1, Data f2 => data_beq f1 f2
| Smx f1, Smx f2 => smx_beq f1 f2
| _, _ => false
end.

Lemma func_beq_sound : forall a b, func_beq a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; solve_expr_beq_sound.
Qed.

Hint Resolve data_beq_sound : expr_beq.


Require Import POCS.

Require Import RemappedDisk.RemappedDiskAPI.
Require Import RemappedDisk.RemappedDiskImpl.
Require Import BadSectorDisk.ExtrBadSectorDisk.

Require Import NBD.NbdData.
Require Import NBD.ExtrServer.

(* TODO: re-use this code for asynchronous implementation *)
Definition d := RemappedDisk.rd BadSectorDisk.bs.

Opaque blockbytes.

Fixpoint read (off:nat) n : prog (bytes (n*blockbytes)) :=
  match n with
  | 0 => Ret bnull
  | S n => b <- Prim d (RemappedDisk.Read off);
            rest <- read (off+1) n;
            Ret (bappend b rest)
  end.

Fixpoint write (off:nat) n (bs:bytes (n*blockbytes)) {struct n} : prog unit.
  destruct n; simpl in *.
  - apply (Ret tt).
  - destruct (bsplit bs) as [b rest].
    apply (Bind (Prim d (RemappedDisk.Write off b))); intros _.
    apply (write (off+1) _ rest).
Defined.

CoFixpoint handle : prog unit :=
  req <- getRequest;
  match req with
  | Read h off blocks =>
    (* TODO: bounds checks *)
    data <- read off blocks;
    _ <- sendResponse
      {| rhandle := h; error := ESuccess; data := data; |};
    handle
  | Write h off _ dat =>
    _ <- write off _ dat;
    _ <- sendResponse
      {| rhandle := h; error := ESuccess; data := bnull |};
    handle
  | Flush h =>
    _ <- sendResponse
      {| rhandle := h; error := ESuccess; data := bnull |};
    handle
  | UnknownOp h =>
    _ <- sendResponse
      {| rhandle := h; error := EInvalid; data := bnull |};
    handle
  | Disconnect => Ret tt
  end.

Definition serverLoop : prog unit :=
  _ <- irec d;
  handle.

Definition diskSize : prog nat :=
  Prim d (RemappedDisk.DiskSize).

Definition init := iInit d.


(** Definition of the physical memory model **)
From iris_c.lib Require Import Coqlib int.
Require Export Integers.
Require Export iris.base_logic.base_logic.

Open Local Scope Z_scope.

Class Sizeof C := sizeof: C → nat.

Arguments sizeof _ _ _ /.
Typeclasses Transparent sizeof.

Definition block : Set := positive.
Definition offset := nat.
Definition addr : Set := prod block offset.

Definition shift_loc l (o: nat) : addr :=
  let '(b, o') := l in (b, o' + o)%nat.

Instance addr_eq_dec : EqDecision addr.
Proof. solve_decision. Defined.

(* Byte-level value *)
Inductive byteval : Set :=
| BVundef
| BVint8 (i: int8)
| BVaddr (p: addr) (k: nat)
| BVnull.

(* High-level value *)
Inductive val : Set :=
| Vvoid
| Vnull
| Vint8 (i: int8)
| Vptr (p: addr)
| Vpair (v1 v2: val).

Global Instance val_eq_dec : EqDecision val.
Proof. solve_decision. Defined.

Global Instance val_equiv: Equiv val := (=).

Instance sizeof_val: Sizeof val :=
  fix go v :=
  match v with
    | Vnull => 4 %nat
    | Vvoid => 0 % nat
    | Vint8 _ => 1 % nat
    | Vptr _ => 4 % nat
    | Vpair v1 v2 => (go v1 + go v2)%nat
  end.

Definition vtrue := Vint8 $ Byte.repr 1.
Definition vfalse := Vint8 $ Byte.repr 0.

Definition b_to_v (b: bool) := if b then vtrue else vfalse.

(** Encoding high-level value to byte-level values **)

Fixpoint encode_int (n: nat) (x: Z): list byte :=
  match n with
    | O => nil
    | S m => Byte.repr x :: encode_int m (x / 256)
  end.

Fixpoint decode_int (l: list byte): Z :=
  match l with
    | nil => 0
    | b :: l' => Byte.unsigned b + decode_int l' * 256
  end.

Lemma encode_int_length:
  forall sz x, length(encode_int sz x) = sz.
Proof.
  induction sz; simpl; intros. auto. decEq. auto.
Qed.

Definition inj_bytes (bl: list byte) : list byteval := List.map BVint8 bl.

Fixpoint proj_bytes (vl: list byteval) : option (list byte) :=
  match vl with
    | nil => Some nil
    | BVint8 b :: vl' =>
      match proj_bytes vl' with None => None | Some bl => Some (b :: bl) end
    | _ => None
  end.

Lemma length_inj_bytes:
  forall bl, length (inj_bytes bl) = length bl.
Proof.
  intros. apply List.map_length.
Qed.

Lemma proj_inj_bytes:
  forall bl, proj_bytes (inj_bytes bl) = Some bl.
Proof.
  induction bl; simpl. auto. rewrite IHbl. auto.
Qed.

Lemma inj_proj_bytes:
  forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl.
Proof.
  induction cl; simpl; intros.
  inv H; auto.
  destruct a; try congruence. destruct (proj_bytes cl); inv H.
  simpl. decEq. auto.
Qed.

Fixpoint inj_pointer (n: nat) (p: addr): list byteval :=
  match n with
    | O => nil
    | S n => BVaddr p n :: inj_pointer n p
  end.

Fixpoint check_pointer (n: nat) (p: addr) (vl: list byteval) : bool :=
  match n, vl with
    | O, nil => true
    | S m, BVaddr p' m' :: vl' =>
      bool_decide (p = p') && beq_nat m m' && check_pointer m p vl'
    | _, _ => false
  end.

Definition proj_pointer (vl: list byteval) : option val :=
  match vl with
    | BVaddr p n :: vl' =>
      if check_pointer 4%nat p vl then Some (Vptr p) else None
    | _ => None
  end.

Fixpoint encode_val (v: val) : list byteval :=
  match v with
    | Vint8 n => inj_bytes (encode_int 1%nat (Byte.unsigned n))
    | Vptr p => inj_pointer 4%nat p
    | Vnull => list_repeat 4 BVnull
    | Vpair v1 v2 => encode_val v1 ++ encode_val v2
    | _ => list_repeat (sizeof v) BVundef
  end.

Lemma size_of_encode_val v:
  length (encode_val v) = sizeof v.
Proof. simpl. induction v=>//. simpl. rewrite app_length. omega. Qed.


Require Import
        Coq.Strings.String
        Coq.Arith.Mult
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Common.DecideableEnsembles
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats.WordOpt
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.StringOpt
        Fiat.Narcissus.Formats.EnumOpt
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignWord
        Fiat.Narcissus.BinLib.AlignedDecoders
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.Tactics.CacheStringConstant.

Require Import
        Bedrock.Word.

Section AlignedList.

  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.

  Fixpoint align_decode_list {A}
           (A_decode_align : forall n,
               Vector.t (word 8) n
               -> CacheDecode
               -> option (A * {n : _ & Vector.t _ n}
                          * CacheDecode))
           (n : nat)
           {sz}
           (v : Vector.t (word 8) sz)
           (cd : CacheDecode)
    : option (list A *  {n : _ & Vector.t _ n} * CacheDecode) :=
    match n with
    | 0 => Some (@nil _, existT _ _ v, cd)
    | S s' => `(x, b1, e1) <- A_decode_align sz v cd;
                `(xs, b2, e2) <- align_decode_list A_decode_align s' (projT2 b1) e1;
                Some ((x :: xs)%list, b2, e2)
    end.

  Lemma optimize_align_decode_list
        {A}
        (A_decode :
           ByteString
           -> CacheDecode
           -> option (A * ByteString * CacheDecode))
        (A_decode_align : forall n,
            Vector.t (word 8) n
            -> CacheDecode
            -> option (A * {n : _ & Vector.t _ n}
                       * CacheDecode))
        (A_decode_OK :
           forall n (v : Vector.t _ n) cd,
             A_decode (build_aligned_ByteString v) cd =
             Ifopt A_decode_align n v cd as a Then
                                              Some (fst (fst a), build_aligned_ByteString (projT2 (snd (fst a))), snd a)
                                              Else
                                              None)
    : forall (n : nat)
             {sz}
             (v : Vector.t (word 8) sz)
             (cd : CacheDecode),
      decode_list A_decode n (build_aligned_ByteString v) cd =
      Ifopt align_decode_list A_decode_align n v cd as a Then
                                                         Some (fst (fst a), build_aligned_ByteString (projT2 (snd (fst a))), snd a)
                                                         Else
                                                         None.
  Proof.
    induction n; simpl; intros; eauto.
    rewrite A_decode_OK.
    rewrite (If_Opt_Then_Else_DecodeBindOpt).
    destruct (A_decode_align sz v cd) as [ [ [? [? ?] ] ?]  | ]; simpl; eauto.
    rewrite IHn.
    rewrite (If_Opt_Then_Else_DecodeBindOpt).
    destruct (align_decode_list A_decode_align n t c)
      as [ [ [? [? ?] ] ?]  | ]; simpl; eauto.
  Qed.

  Fixpoint align_format_list {A}
           (A_format_align :
              A
              ->  CacheFormat
              -> {n : _ & Vector.t (word 8) n} * CacheFormat)
           (As : list A)
           (ce : CacheFormat)
    : {n : _ & Vector.t (word 8) n} * CacheFormat :=
    match As with
    | nil => (existT _ _ (Vector.nil _), ce)
    | a :: As' =>
      let (b, ce') := A_format_align a ce in
      let (b', ce'') := align_format_list A_format_align As' ce' in
      (existT _ _ (append (projT2 b) (projT2 b')), ce'')
    end.

  Lemma optimize_align_format_list
        {A}
        (A_OK : A -> Prop)
        (format_A : A -> CacheFormat -> Comp (ByteString * CacheFormat))
        (A_format_align :
           A
           ->  CacheFormat
           -> {n : _ & Vector.t (word 8) n} * CacheFormat)
        (A_format_OK :
           forall a ce,
             A_OK a
             -> refine (format_A a ce)
                    (ret (let (v', ce') := A_format_align a ce in
                          (build_aligned_ByteString (projT2 v'), ce'))))
    : forall (As : list A)
             (ce : CacheFormat),
      (forall a, In a As -> A_OK a)
      -> refine (format_list format_A As ce)
             (let (v', ce') := (align_format_list A_format_align As ce) in
              ret (build_aligned_ByteString (projT2 v'), ce')).
  Proof.
    induction As; simpl; intros; simpl.
    - simpl.
      repeat f_equiv.
      eapply ByteString_f_equal.
      instantiate (1 := eq_refl _); reflexivity.
      instantiate (1 := eq_refl _); reflexivity.
    - unfold Bind2.
      rewrite A_format_OK; eauto; simplify with monad laws.
      rewrite IHAs.
      destruct (A_format_align a ce); simpl.
      destruct (align_format_list A_format_align As c);
        simplify with monad laws.
      simpl.
      rewrite <- build_aligned_ByteString_append.
      reflexivity.
      intuition.
  Qed.

  Lemma AlignedFormatListThenC {A}
        (A_OK : A -> Prop)
        format_A
        (encode_A : A -> CacheFormat -> {n : nat & t (word 8) n} * CacheFormat)
    : forall (l : list A) ce (c : _ -> Comp _)
             (v' : _ -> {n : nat & t (word 8) n})
             (ce' : _ -> CacheFormat),
      (forall (a : A) (ce : CacheFormat),
          A_OK a ->
          refine (format_A a ce) (ret (let (v', ce') := encode_A a ce in (build_aligned_ByteString (projT2 v'), ce'))))
      -> (forall v ce'',
             format_list format_A l ce ↝ (v, ce'') ->
             refine (c ce'') (ret (build_aligned_ByteString (projT2 (v' ce'')), ce' ce'')))
      -> (forall a : A, In a l -> A_OK a)
      -> refine (((format_list format_A l)
                    ThenC c) ce)
                (ret (let (v, ce'') := align_format_list encode_A l ce in
                      build_aligned_ByteString
                        (Vector.append (projT2 v) (projT2 (v' ce''))),
                      let (v, ce'') := align_format_list encode_A l ce in
                      ce' ce'')).
  Proof.
    intros.
    etransitivity.
    eapply AlignedFormatThenC.
    rewrite (optimize_align_format_list A_OK format_A encode_A); try eassumption.
    match goal with
      |- context [let (v, c) := ?z in ret (@?b v c)] =>
      rewrite (zeta_inside_ret z _)
    end.
    rewrite zeta_to_fst; simpl.
    instantiate (2 := fun ce => fst (_ ce)).
    instantiate (1 := fun ce => snd (_ ce)).
    simpl; reflexivity.
    intros; eapply H0; eauto.
    simpl.
    rewrite !zeta_to_fst; simpl; reflexivity.
  Qed.

  Lemma AlignedFormatListDoneC {A}
        (A_OK : A -> Prop)
        format_A
        (encode_An : A -> CacheFormat -> nat)
        (encode_A1 : forall a ce,  t (word 8) (encode_An a ce))
        (encode_A2 : A -> CacheFormat -> CacheFormat)
    : forall (l : list A) ce,
      (forall (a : A) (ce : CacheFormat),
          A_OK a
          -> refine (format_A a ce) (ret (build_aligned_ByteString (encode_A1 a ce), encode_A2 a ce)))
      -> (forall a : A, In a l -> A_OK a)
      -> refine (((format_list format_A l) DoneC) ce)
                (ret (build_aligned_ByteString (projT2 (fst (align_format_list (fun a ce => (existT _ _ (encode_A1 a ce), encode_A2 a ce)) l ce))),
                      let (v, ce'') := align_format_list (fun a ce => (existT _ _ (encode_A1 a ce), encode_A2 a ce)) l ce in
                      ce'')).
  Proof.
    intros.
    etransitivity.
    eapply AlignedFormatDoneC.
    rewrite (optimize_align_format_list A_OK format_A (fun a ce => (existT _ _ (encode_A1 a ce), encode_A2 a ce))); try eassumption.
    match goal with
      |- context [let (v, c) := ?z in ret (@?b v c)] =>
      rewrite (zeta_inside_ret z _)
    end.
    rewrite zeta_to_fst; simpl.
    instantiate (2 := fun ce => fst (_ ce)).
    instantiate (1 := fun ce => snd (_ ce)).
    simpl; reflexivity.
    intros; rewrite zeta_to_fst; simpl; reflexivity.
  Qed.

End AlignedList.


(* PREAMBLE *)

From compcert.cfrontend           Require Csem.
From compcert.common              Require Values.
From compcert.lib                 Require Coqlib.

From trancert.lib                 Require All.
From trancert.properties.memory   Require Permissions.
From trancert.simulations.memory.bijection
                                  Require Def ToInjection.

Import lib.All
       bijection.Def bijection.AST
       Coqlib bijection.ToInjection
       compcert.common.Values
       Values.Val
       memory.Permissions
       Memory Mem.

Section DropPerm.

  Lemma embedding_no_overlap_biject:
    forall M m1 m2,
      biject M m1 m2 ->
      meminj_no_overlap (m_fwd M) m1 ->
      meminj_no_overlap (m_bwd M) m2.
  Proof.
    unfold meminj_no_overlap.
    intros [] m1 m2 [] H0 b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 Hneq Hgb1 Hgb2 Hperm1 Hperm2.
    edestruct to_meminj_delta with (delta := delta1); eauto.
    edestruct to_meminj_delta with (delta := delta2); eauto.
    subst.
    rewrite Z.add_0_r .
    destruct (peq b1' b2'); auto.
    exfalso.
    subst.
    eapply m_inv in H; eauto.
    eapply m_inv in H2; eauto.
    rewrite H in H2. by autoinj.
  Qed.

End DropPerm.


From stdpp Require Export sets gmultiset countable.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From iris Require Import options.

(* The multiset union CMRA *)
Section gmultiset.
  Context `{Countable K}.
  Implicit Types X Y : gmultiset K.

  Canonical Structure gmultisetO := discreteO (gmultiset K).

  Instance gmultiset_valid : Valid (gmultiset K) := λ _, True.
  Instance gmultiset_validN : ValidN (gmultiset K) := λ _ _, True.
  Instance gmultiset_unit : Unit (gmultiset K) := (∅ : gmultiset K).
  Instance gmultiset_op : Op (gmultiset K) := disj_union.
  Instance gmultiset_pcore : PCore (gmultiset K) := λ X, Some ∅.

  Lemma gmultiset_op_disj_union X Y : X ⋅ Y = X ⊎ Y.
  Proof. done. Qed.
  Lemma gmultiset_core_empty X : core X = ∅.
  Proof. done. Qed.
  Lemma gmultiset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->%leibniz_equiv].
      rewrite gmultiset_op_disj_union. apply gmultiset_disj_union_subseteq_l.
    - intros ->%gmultiset_disj_union_difference. by exists (Y ∖ X).
  Qed.

  Lemma gmultiset_ra_mixin : RAMixin (gmultiset K).
  Proof.
    apply ra_total_mixin; eauto.
    - by intros X Y Z ->%leibniz_equiv.
    - by intros X Y ->%leibniz_equiv.
    - solve_proper.
    - intros X1 X2 X3. by rewrite !gmultiset_op_disj_union assoc_L.
    - intros X1 X2. by rewrite !gmultiset_op_disj_union comm_L.
    - intros X. by rewrite gmultiset_core_empty left_id.
    - intros X1 X2 HX. rewrite !gmultiset_core_empty. exists ∅.
      by rewrite left_id.
  Qed.

  Canonical Structure gmultisetR := discreteR (gmultiset K) gmultiset_ra_mixin.

  Global Instance gmultiset_cmra_discrete : CmraDiscrete gmultisetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gmultiset_ucmra_mixin : UcmraMixin (gmultiset K).
  Proof. split. done. intros X. by rewrite gmultiset_op_disj_union left_id_L. done. Qed.
  Canonical Structure gmultisetUR := UcmraT (gmultiset K) gmultiset_ucmra_mixin.

  Global Instance gmultiset_cancelable X : Cancelable X.
  Proof.
    apply: discrete_cancelable=> Y Z _ ?. fold_leibniz. by apply (inj (X ⊎.)).
  Qed.

  Lemma gmultiset_opM X mY : X ⋅? mY = X ⊎ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma gmultiset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma gmultiset_local_update X Y X' Y' : X ⊎ Y' = X' ⊎ Y → (X,Y) ~l~> (X', Y').
  Proof.
    intros HXY. rewrite local_update_unital_discrete=> Z' _. intros ->%leibniz_equiv.
    split; first done. apply leibniz_equiv_iff, (inj (.⊎ Y)).
    rewrite -HXY !gmultiset_op_disj_union.
    by rewrite -(comm_L _ Y) (comm_L _ Y') assoc_L.
  Qed.

  Lemma gmultiset_local_update_alloc X Y X' : (X,Y) ~l~> (X ⊎ X', Y ⊎ X').
  Proof. apply gmultiset_local_update. by rewrite (comm_L _ Y) assoc_L. Qed.

  Lemma gmultiset_local_update_dealloc X Y X' :
    X' ⊆ Y → (X,Y) ~l~> (X ∖ X', Y ∖ X').
  Proof.
    intros ->%gmultiset_disj_union_difference. apply local_update_total_valid.
    intros _ _ ->%gmultiset_included%gmultiset_disj_union_difference.
    apply gmultiset_local_update. apply gmultiset_eq=> x.
    repeat (rewrite multiplicity_difference || rewrite multiplicity_disj_union).
    lia.
  Qed.
End gmultiset.

Arguments gmultisetO _ {_ _}.
Arguments gmultisetR _ {_ _}.
Arguments gmultisetUR _ {_ _}.