From stdpp Require Export namespaces.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap.
From iris.base_logic.lib Require Export fancy_updates fupd_level.
From iris.base_logic.lib Require Import wsat.
From iris.prelude Require Import options.
Import uPred.

(** Always Enabled Semantic Invariants *)
Definition ae_inv_def `{!invG Σ} (k : nat) (mj: option nat) (P : iProp Σ) : iProp Σ :=
  □ ∀ Q E, (match mj with
            | None =>
              match k with
              | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
              | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
              end
            | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
            end)
             -∗ |k,mj={E}=> Q.
Definition ae_inv_aux : seal (@ae_inv_def). Proof. by eexists. Qed.
Definition ae_inv {Σ i} := ae_inv_aux.(unseal) Σ i.
Definition ae_inv_eq : @ae_inv = @ae_inv_def := ae_inv_aux.(seal_eq).
Instance: Params (@ae_inv) 3 := {}.
Typeclasses Opaque ae_inv.

Local Hint Extern 0 (AE _ _ ## MaybeEn _) => apply AE_MaybeEn_disj : core.
Local Hint Extern 0 (AlwaysEn ## MaybeEn _) => apply coPset_inl_inr_disj : core.

(** * Ae_Invariants *)
Section ae_inv.
  Context `{!invG Σ}.
  Implicit Types i : positive.
  Implicit Types E : coPset.
  Implicit Types P Q R : iProp Σ.

  (** ** Internal model of ae_invariants *)
  Definition own_ae_inv (k: nat) (mj: option nat) (P : iProp Σ) : iProp Σ :=
    ∃ i, ⌜i ∈ AE_next_diff (S k) mj⌝ ∧ ownI k i (bi_sch_var_fixed O) (list_to_vec [P]).

  Lemma own_ae_inv_acc_k E k mj P Q :
    own_ae_inv k mj P -∗
    (match mj with
     | None =>
       match k with
       | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
       | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
       end
     | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
     end) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def. iDestruct 1 as (i) "[Hi #HiP]".
    iDestruct "Hi" as % ?%elem_of_subseteq_singleton. iIntros "Hshift".
    rewrite ?(ownE_op (AE _ _)) // ownE_AE_split_current_rest.
    rewrite {1 2}(union_difference_L {[ i ]} (AE_next_diff (S k) mj)) // ownE_op; last set_solver.
    iIntros "(Hw & ((Hi&HAE')&HAE) & HE)".
    iDestruct (ownI_open k i with "[$Hw $Hi $HiP]") as "(Hw & HI & HD)".
    iDestruct "HI" as (? Ps_mut) "(Hinterp&Hmut)".
    iEval (rewrite ?bi_schema_interp_unfold /=) in "Hinterp".
    destruct mj; last first.
    - { destruct k.
        - iMod ("Hshift" with "[$]") as ">(HP&HQ)".
          iDestruct (ownI_close O i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
          { iFrame "# ∗". }
          iFrame. eauto.
        - iDestruct (wsat_le_acc (S k) with "Hw") as "(Hw&Hclo)"; first lia.
          rewrite ownE_op //.
          iMod ("Hshift" with "Hinterp [$Hw $HAE $HE]") as ">(Hw&(HAE&HE)&HP&HQ)".
          iDestruct ("Hclo" with "[$]") as "Hw".
          iDestruct (ownI_close (S k) i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
          { iFrame "# ∗". }
          iFrame. eauto.
      }
    - rewrite ownE_op //.
      iMod ("Hshift" with "Hinterp [$Hw $HAE $HE]") as ">(Hw&(HAE&HE)&HP&HQ)".
      iDestruct (ownI_close k i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
      { iFrame "# ∗". rewrite bi_schema_interp_unfold /=. eauto. }
      iFrame. eauto.
  Qed.

  Lemma own_ae_inv_acc_simple E k mj P Q:
    own_ae_inv k mj P -∗
    (match k with
     | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
     | S k' => ▷ P -∗ |k'={E}=> ▷ P ∗ Q
     end) -∗
    |={E}=> Q.
  Proof.
    iIntros "Hown Hshift". iApply (fupd_split_level_fupd E _ _ k mj).
    iApply (own_ae_inv_acc_k E with "Hown [Hshift]").
    { destruct k; destruct mj.
      - iIntros. iMod ("Hshift" with "[$]") as ">?". iModIntro. eauto.
      - iIntros. iMod ("Hshift" with "[$]") as ">?". iModIntro. eauto.
      - iIntros. iSpecialize ("Hshift" with "[$]").
        iApply (fupd_level_split_level with "Hshift"); lia.
      - iIntros. iSpecialize ("Hshift" with "[$]").
        iApply (fupd_level_split_level with "Hshift"); lia.
    }
  Qed.

  Lemma fresh_ae_inv_name (E : gset positive) k mj : ∃ i, i ∉ E ∧ i ∈ AE_next_diff (S k) mj.
  Proof.
    exists (coPpick (AE_next_diff (S k) mj ∖gset_to_coPset E)).
    rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
    apply coPpick_elem_of=> Hfin.
    eapply AE_next_diff_inf, (difference_finite_inv _ _), Hfin.
    apply gset_to_coPset_finite.
  Qed.

  Lemma own_ae_inv_alloc_k E k mj P : ▷ P -∗ |k,mj={E}=> own_ae_inv k mj P.
  Proof.
    rewrite uPred_fupd_split_level_eq. iIntros "HP [Hw $]".
    iMod (ownI_alloc (.∈ AE_next_diff (S k) mj) (bi_sch_var_fixed O) k (list_to_vec [P]) (list_to_vec [])
            with "[HP $Hw]") as (i ?) "[$ [? ?]]"; auto using fresh_ae_inv_name.
    { rewrite bi_schema_interp_unfold //=. }
    do 2 iModIntro. iExists i. auto.
  Qed.

  Lemma own_ae_inv_alloc k mj E P : ▷ P ={E}=∗ own_ae_inv k mj P.
  Proof. iIntros "HP". iApply (fupd_split_level_fupd). by iApply own_ae_inv_alloc_k. Qed.

  Lemma own_ae_inv_to_ae_inv k mj P: own_ae_inv k mj P -∗ ae_inv k mj P.
  Proof.
    iIntros "#I". rewrite ae_inv_eq. iIntros (E H).
    iPoseProof (own_ae_inv_acc_k with "I") as "H"; eauto.
  Qed.

  (** ** Public API of ae_invariants *)
  Global Instance ae_inv_contractive n mj : Contractive (ae_inv n mj).
  Proof. rewrite ae_inv_eq. solve_contractive. Qed.

  Global Instance ae_inv_ne n mj : NonExpansive (ae_inv n mj).
  Proof. apply contractive_ne, _. Qed.

  Global Instance ae_inv_proper n mj : Proper (equiv ==> equiv) (ae_inv n mj).
  Proof. apply ne_proper, _. Qed.

  Global Instance ae_inv_persistent n mj P : Persistent (ae_inv n mj P).
  Proof. rewrite ae_inv_eq. apply _. Qed.

  Lemma ae_inv_alter n mj P Q : ae_inv n mj P -∗ ▷ □ (P -∗ Q ∗ (Q -∗ P)) -∗ ae_inv n mj Q.
  Proof.
    rewrite ae_inv_eq. iIntros "#HI #HPQ !>" (Q' H). iIntros "Hshift".
    iMod ("HI" $! Q' H with "[Hshift]") as "$"; last done.
    { destruct mj.
      { iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as "(HQ&$)".
        iModIntro. iModIntro. by iApply ("HQP").
      }
      destruct n.
      - iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as ">(HQ&$)".
        iModIntro. iModIntro. iNext. by iApply ("HQP").
      - iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as "(HQ&$)".
        iModIntro. iNext. by iApply ("HQP").
    }
  Qed.

  Lemma ae_inv_iff n mj P Q : ae_inv n mj P -∗ ▷ □ (P ↔ Q) -∗ ae_inv n mj Q.
  Proof.
    iIntros "#HI #HPQ". iApply (ae_inv_alter with "HI").
    iIntros "!> !> HP". iSplitL "HP".
    - by iApply "HPQ".
    - iIntros "HQ". by iApply "HPQ".
  Qed.

  Lemma ae_inv_alloc' k mj E P : ▷ P -∗ |k,mj={E}=> ae_inv k mj P.
  Proof.
    iIntros "HP". iApply own_ae_inv_to_ae_inv.
    iApply (own_ae_inv_alloc_k E k with "HP").
  Qed.

  Lemma ae_inv_alloc k mj E P : ▷ P ={E}=∗ ae_inv k mj P.
  Proof.
    iIntros "HP". iApply own_ae_inv_to_ae_inv.
    iApply (own_ae_inv_alloc k mj E with "HP").
  Qed.

  Lemma ae_inv_acc E k mj P Q :
    ae_inv k mj P -∗
    (match mj with
     | None =>
       match k with
       | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
       | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
       end
     | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
     end) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite ae_inv_eq /ae_inv_def. iIntros "#HI"; by iApply "HI".
  Qed.

  Lemma ae_inv_acc_bupd E k mj P Q :
    ae_inv k mj P -∗
    (▷ P ==∗ ◇ (▷ P ∗ Q)) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite ae_inv_eq /ae_inv_def. iIntros "#HI Hshift".
    iApply "HI".
    { destruct mj, k; eauto; iIntros; by iMod ("Hshift" with "[$]") as ">$". }
  Qed.

  Lemma ae_inv_accS_simple E k mj P Q :
    ae_inv (S k) mj P -∗
    (▷ P -∗ |k,(Some O)={E}=> ▷ P ∗ Q) -∗
    |(S k),mj={E}=> Q.
  Proof.
    iIntros "H Hshift".
    iApply (ae_inv_acc with "[$] [Hshift]").
    destruct mj; iIntros "HP"; iSpecialize ("Hshift" with "[$]");
      iApply (fupd_split_level_le with "[$]"); naive_solver lia.
  Qed.

  (** ** Proof mode integration *)
  (*
  Global Instance into_ae_inv_ae_inv N P : IntoAe_Inv (ae_inv N P) N := {}.

  Global Instance into_acc_ae_inv_lvl k N P E:
    IntoAcc (X := unit) (ae_inv N P)
            (↑N ⊆ E) True (uPred_fupd_level E (E ∖ ↑N) k) (uPred_fupd_level (E ∖ ↑N) E k)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite ae_inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hae_inv _". iApply (fupd_level_le _ _ O); first lia.
    iMod ("Hae_inv" $! _ with "[//]") as "($&Hcl)".
    iModIntro. iIntros "H". iSpecialize ("Hcl" with "H").
    iApply (fupd_level_le with "Hcl"); first lia.
  Qed.

  Global Instance into_acc_ae_inv N P E:
    IntoAcc (X := unit) (ae_inv N P)
            (↑N ⊆ E) True (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite ae_inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hae_inv _". iApply (fupd_level_fupd _ _ _ O).
    iMod ("Hae_inv" $! _ with "[//]") as "($&Hcl)".
    iModIntro. iIntros "H". iSpecialize ("Hcl" with "H").
    iApply (fupd_level_fupd with "Hcl").
  Qed.

  (** ** Derived properties *)
  Lemma ae_inv_acc_strong E N P :
    ↑N ⊆ E → ae_inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
  Proof.
    iIntros (?) "Hae_inv".
    iPoseProof (ae_inv_acc (↑ N) N with "Hae_inv") as "H"; first done.
    rewrite difference_diag_L.
    iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
    rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
    iIntros (E') "HP".
    iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
    by rewrite left_id_L.
  Qed.

  Lemma ae_inv_acc_timeless E N P `{!Timeless P} :
    ↑N ⊆ E → ae_inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "Hae_inv". iMod (ae_inv_acc with "Hae_inv") as "[>HP Hclose]"; auto.
    iIntros "!> {$HP} HP". iApply "Hclose"; auto.
  Qed.

  Lemma ae_inv_split_l N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N P.
  Proof.
    iIntros "#HI". iApply ae_inv_alter; eauto.
    iIntros "!> !> [$ $] $".
  Qed.
  Lemma ae_inv_split_r N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N Q.
  Proof.
    rewrite (comm _ P Q). eapply ae_inv_split_l.
  Qed.
  Lemma ae_inv_split N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N P ∗ ae_inv N Q.
  Proof.
    iIntros "#H".
    iPoseProof (ae_inv_split_l with "H") as "$".
    iPoseProof (ae_inv_split_r with "H") as "$".
  Qed.
   *)

End ae_inv.


Require Import Lia.
Require Import RelationClasses.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.

Require Import AMemory.
Require Import ALocal.
Require Import AThread.

Require Import APF.
Require Import PF.

Lemma promise_apromise
  :
    Memory.promise <9= AMemory.promise.
Proof.
  i. inv PR; econs; eauto.
Qed.

Lemma write_awrite
  :
    Memory.write <10= AMemory.write.
Proof.
  i. inv PR; econs; eauto.
  eapply promise_apromise; eauto.
Qed.

Lemma program_step_aprogram_step
  :
    Thread.program_step <4= AThread.program_step.
Proof.
  i. inv PR. inv LOCAL.
  - econs; eauto.
  - econs; eauto.
  - inv LOCAL0. econs; eauto. econs; eauto.
    econs; eauto. eapply write_awrite; eauto.
  - inv LOCAL2. econs; eauto. econs; eauto.
    econs; eauto. eapply write_awrite; eauto.
  - econs; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma thread_step_athread_step
  :
    Thread.step_allpf <4= AThread.step_allpf.
Proof.
  i. inv PR. inv STEP.
  - inv STEP0. inv LOCAL. econs; eauto. econs; eauto.
    econs; eauto. econs; eauto. eapply promise_apromise; eauto.
  - econs. econs 2. eapply program_step_aprogram_step; eauto.
Qed.

Lemma thread_steps_athread_steps lang
  :
    rtc (tau (@Thread.step_allpf lang)) <2= rtc (tau (@AThread.step_allpf lang)).
Proof.
  eapply rtc_implies. i. inv H. econs; eauto.
  eapply thread_step_athread_step; eauto.
Qed.

Lemma program_steps_aprogram_steps lang
  :
    rtc (tau (@Thread.program_step lang)) <2= rtc (tau (@AThread.program_step lang)).
Proof.
  eapply rtc_implies. i. inv H. econs; eauto.
  eapply program_step_aprogram_step; eauto.
Qed.

Lemma pfstep_apfstep:
  PFConfiguration.step <4= APFConfiguration.step.
Proof.
  ii. inv PR.
  eapply program_steps_aprogram_steps in STEPS.
  eapply program_step_aprogram_step in STEP.
  econs; eauto.
Qed.

Record shorter (mem_src mem_tgt: Memory.t): Prop :=
  shorter_intro
    {
      shorter_get: forall loc to from msg (GET: Memory.get loc to mem_tgt = Some (from, msg)),
        exists from', (<<GET: Memory.get loc to mem_src = Some (from', msg)>>);

      shorter_get_iff: forall loc to from' msg (GET: Memory.get loc to mem_src = Some (from', msg)),
          exists from msg, (<<GET: Memory.get loc to mem_tgt = Some (from, msg)>>) /\
                           (<<TS: Time.le from from'>>) /\
                           (<<ATTATCH:
                              forall (BLANK: Memory.get loc from' mem_src = None),
                                Time.lt from from'>>);
    }
.

Lemma shorter_write mem_src0 mem_tgt0 loc from to val released prom1 mem_tgt1 kind
      (WRITE: AMemory.write Memory.bot mem_tgt0 loc from to val released prom1 mem_tgt1 kind)
      (SHORT: shorter mem_src0 mem_tgt0)
  :
    exists from' mem_src1,
      (<<WRITE: Memory.write Memory.bot mem_src0 loc from' to val released prom1 mem_src1 kind>>) /\
      (<<SHORT: shorter mem_src1 mem_tgt1>>).
Proof.
  exploit APFConfiguration.write_no_promise; eauto. i. des. clarify.
  inv WRITE. inv PROMISE. exists (Time.middle from to).
  assert (WF: (<<MSG_WF: Message.wf (Message.full val released)>>) /\
              (<<TO: Time.lt from to>>) /\
              (<<DISJOINT: forall to2 from2 msg2
                                  (GET: Memory.get loc to2 mem_tgt0 = Some (from2, msg2)),
                  Interval.disjoint (from, to) (from2, to2)>>)).
  { inv MEM. inv ADD. splits; auto. } des.
  exploit (@Memory.add_exists mem_src0 loc (Time.middle from to) to (Message.full val released)).
  { ii. inv LHS. inv RHS. ss.
    eapply shorter_get_iff in GET2; eauto. des.
    eapply DISJOINT; eauto.
    - instantiate (1:=x). econs; ss. etrans.
      + eapply Time.middle_spec; eauto.
      + eauto.
    - econs; ss. eapply TimeFacts.le_lt_lt; eauto.
  }
  { eapply Time.middle_spec; eauto. }
  { ss. }
  intros [mem_src1 ADD].
  exploit (Memory.add_exists_le).
  { eapply Memory.bot_le. }
  { eapply ADD. } intros [prom0' ADDPROM].
  exploit Memory.remove_exists.
  { eapply Memory.add_get0. eapply ADDPROM. } intros [prom1 REMOVEPROM].

  exists mem_src1. split.
  - econs.
    + econs; eauto; i; clarify.
      dup GET. eapply shorter_get_iff in GET; eauto. des.
      dup GET1. eapply shorter_get in GET1; eauto. des. clarify.
      eapply DISJOINT; eauto.
      * instantiate (1:=to). econs; ss. refl.
      * econs; ss.
        { eapply ATTATCH; eauto.
          eapply Memory.add_get0 in ADD. des. clarify. }
        { eapply Memory.get_ts in GET. des; auto.
          - clarify. refl.
          - left. auto. }
    + exploit MemoryFacts.add_remove_eq; eauto. i. clarify.

  - econs.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits. eapply Memory.add_get0; eauto.
      * guardH o. dup GET. eapply shorter_get in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits.
        { eapply Memory.add_get0; eauto. }
        { left. eapply Time.middle_spec; eauto. }
        { i. eapply Time.middle_spec; eauto. }
      * guardH o. dup GET. eapply shorter_get_iff in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
        esplits; eauto.
        i. eapply ATTATCH. destruct (Memory.get loc0 from' mem_src0) eqn:GET3; auto.
        destruct p. eapply Memory.add_get1 in GET3; eauto. clarify.
Qed.

Lemma shorter_update mem_src0 mem_tgt0 loc from to val released prom1 mem_tgt1 kind
      (WRITE: AMemory.write Memory.bot mem_tgt0 loc from to val released prom1 mem_tgt1 kind)
      ts msg
      (READ: Memory.get loc from mem_tgt0 = Some (ts, msg))
      (SHORT: shorter mem_src0 mem_tgt0)
  :
    exists mem_src1,
      (<<WRITE: Memory.write Memory.bot mem_src0 loc from to val released prom1 mem_src1 kind>>) /\
      (<<SHORT: shorter mem_src1 mem_tgt1>>).
Proof.
  exploit APFConfiguration.write_no_promise; eauto. i. des. clarify.
  inv WRITE. inv PROMISE.
  assert (WF: (<<MSG_WF: Message.wf (Message.full val released)>>) /\
              (<<TO: Time.lt from to>>) /\
              (<<DISJOINT: forall to2 from2 msg2
                                  (GET: Memory.get loc to2 mem_tgt0 = Some (from2, msg2)),
                  Interval.disjoint (from, to) (from2, to2)>>)).
  { inv MEM. inv ADD. splits; auto. } des.
  exploit (@Memory.add_exists mem_src0 loc from to (Message.full val released)).
  { ii. inv LHS. inv RHS. ss.
    eapply shorter_get_iff in GET2; eauto. des.
    eapply DISJOINT; eauto.
    - instantiate (1:=x). econs; ss.
    - econs; ss. eapply TimeFacts.le_lt_lt; eauto.
  }
  { ss. }
  { ss. }
  intros [mem_src1 ADD].
  exploit (Memory.add_exists_le).
  { eapply Memory.bot_le. }
  { eapply ADD. } intros [prom0' ADDPROM].
  exploit Memory.remove_exists.
  { eapply Memory.add_get0. eapply ADDPROM. } intros [prom1 REMOVEPROM].

  exists mem_src1. split.
  - econs.
    + econs; eauto; i; clarify.
      dup GET. eapply shorter_get_iff in GET; eauto. des.
      dup GET1. eapply shorter_get in GET1; eauto. des. clarify.
      eapply DISJOINT; eauto.
      * instantiate (1:=to). econs; ss. refl.
      * econs; ss.
        { eapply ATTATCH; eauto.
          eapply Memory.add_get0 in ADD. des. clarify. }
        { eapply Memory.get_ts in GET. des; auto.
          - clarify. refl.
          - left. auto. }
    + exploit MemoryFacts.add_remove_eq; eauto. i. clarify.
  - econs.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits. eapply Memory.add_get0; eauto.
      * guardH o. dup GET. eapply shorter_get in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits.
        { eapply Memory.add_get0; eauto. }
        { refl. }
        { i. eapply shorter_get in READ; eauto. des.
          eapply Memory.add_get1 in GET; eauto. clarify. }
      * guardH o. dup GET. eapply shorter_get_iff in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
        esplits; eauto.
        i. eapply ATTATCH. destruct (Memory.get loc0 from' mem_src0) eqn:GET3; auto.
        destruct p. eapply Memory.add_get1 in GET3; eauto. clarify.
Qed.

Lemma shorter_program_step lang th_src th_tgt th_tgt' st st' v v' prom' sc sc'
      mem_tgt mem_tgt' mem_src e_tgt
      (STEP: AThread.program_step e_tgt th_tgt th_tgt')
      (SHORT: shorter mem_src mem_tgt)
      (TH_SRC: th_src = Thread.mk lang st (Local.mk v Memory.bot) sc mem_src)
      (TH_TGT0: th_tgt = Thread.mk lang st (Local.mk v Memory.bot) sc mem_tgt)
      (TH_TGT1: th_tgt' = Thread.mk lang st' (Local.mk v' prom') sc' mem_tgt')
  :
    exists mem_src' e_src,
      (<<STEP: Thread.program_step
                 e_src th_src
                 (Thread.mk lang st' (Local.mk v' prom') sc' mem_src')>>) /\
      (<<SHORT: shorter mem_src' mem_tgt'>>) /\
      (<<EVENT: ThreadEvent.get_machine_event e_tgt = ThreadEvent.get_machine_event e_src>>)
.
Proof.
  inv STEP. clarify. inv LOCAL.
  - esplits; eauto. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto. econs; eauto.
    eapply shorter_get in GET; eauto. des. econs; eauto.
  - inv LOCAL0. ss. clarify.
    exploit shorter_write; eauto. i. des. exists mem_src1.
    esplits; eauto.
    + econs; eauto; ss.
    + ss.
  - inv LOCAL1. inv LOCAL2. clarify.
    dup GET. eapply shorter_get in GET; eauto. des.
    exploit shorter_update; eauto. i. des. exists mem_src1.
    esplits; eauto. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
Qed.

Lemma shorter_program_steps lang th_src th_tgt th_tgt' st st' v v' prom' sc sc'
      mem_tgt mem_tgt' mem_src
      (STEPS: rtc (tau (@AThread.program_step lang)) th_tgt th_tgt')
      (SHORT: shorter mem_src mem_tgt)
      (TH_SRC: th_src = Thread.mk lang st (Local.mk v Memory.bot) sc mem_src)
      (TH_TGT0: th_tgt = Thread.mk lang st (Local.mk v Memory.bot) sc mem_tgt)
      (TH_TGT1: th_tgt' = Thread.mk lang st' (Local.mk v' prom') sc' mem_tgt')
  :
    exists mem_src',
      (<<STEPS: rtc (tau (@Thread.program_step lang))
                    th_src
                    (Thread.mk lang st' (Local.mk v' prom') sc' mem_src')>>) /\
      (<<SHORT: shorter mem_src' mem_tgt'>>)
.
Proof.
  ginduction STEPS.
  - i. clarify. esplits; eauto.
  - i. clarify. inv H. destruct y. destruct local.
    exploit shorter_program_step; eauto. i. des.
    exploit PFConfiguration.program_step_no_promise; eauto. i. ss. clarify.
    exploit IHSTEPS; eauto. i. des. esplits; eauto.
    econs; eauto. econs; eauto. rewrite <- EVENT. auto.
Qed.

Inductive sim_apf_pf: Configuration.t -> Configuration.t -> Prop :=
| sim_apf_pf_intro
    c_src c_tgt
    ths sc mem_src mem_tgt
    (SRC: c_src = Configuration.mk ths sc mem_src)
    (TGT: c_tgt = Configuration.mk ths sc mem_tgt)
    (PROMISESRC: ~ Configuration.has_promise c_src)
    (PROMISETGT: ~ Configuration.has_promise c_tgt)
    (MEMORY: shorter mem_src mem_tgt)
  :
    sim_apf_pf c_src c_tgt
.

Lemma sim_apf_pf_step c_tgt0 c_tgt1 c_src0 tid e
      (SIM: sim_apf_pf c_src0 c_tgt0)
      (STEP: APFConfiguration.step tid e c_tgt0 c_tgt1)
  :
    exists c_src1,
      (<<STEP: PFConfiguration.step tid e c_src0 c_src1>>) /\
      (<<SIM: sim_apf_pf c_src1 c_tgt1>>).
Proof.
  inv SIM. dup STEP. inv STEP. ss. destruct e2. destruct lc1, local, lc3.
  exploit APFConfiguration.no_promise_spec; eauto. i. ss. clarify.
  exploit shorter_program_steps; eauto. i. des.
  exploit APFConfiguration.program_steps_no_promise; eauto. i. ss. clarify.
  exploit shorter_program_step; eauto. i. des.
  assert (STEPSRC: PFConfiguration.step
                     (ThreadEvent.get_machine_event e_src) e
                     (Configuration.mk ths sc mem_src)
                     (Configuration.mk (IdentMap.add e (existT _ lang st3, Local.mk tview1 promises1) ths) sc3 mem_src'0)).
  { econs; eauto. }
  rewrite EVENT. esplits; eauto. econs; eauto.
  - eapply PFConfiguration.configuration_step_no_promise in STEPSRC; eauto.
  - eapply APFConfiguration.configuration_step_no_promise in STEP0; eauto.
Qed.

Lemma sim_apf_pf_init s
  :
    sim_apf_pf (Configuration.init s) (Configuration.init s).
Proof.
  econs; ss.
  - ii. inv H. ss. unfold Threads.init in FIND.
    erewrite IdentMap.Properties.F.map_o in *.
    unfold option_map, Local.init in *. des_ifs. ss. erewrite Memory.bot_get in GET. clarify.
  - ii. inv H. ss. unfold Threads.init in FIND.
    erewrite IdentMap.Properties.F.map_o in *.
    unfold option_map, Local.init in *. des_ifs. ss. erewrite Memory.bot_get in GET. clarify.
  - econs; i.
    + unfold Memory.init, Memory.get in *. erewrite Cell.init_get in *.
      des_ifs. esplits; eauto.
    + unfold Memory.init, Memory.get in *. erewrite Cell.init_get in *.
      des_ifs. esplits; eauto.
      * refl.
      * i. erewrite Cell.init_get in *. des_ifs.
Qed.

Lemma sim_apf_pf_terminal c_src c_tgt
      (SIM: sim_apf_pf c_src c_tgt)
      (TERMINAL: Configuration.is_terminal c_tgt)
  :
    Configuration.is_terminal c_src.
Proof.
  inv SIM. ii. eauto.
Qed.

Lemma sim_apf_pf_adequacy c_src c_tgt
      (SIM: sim_apf_pf c_src c_tgt)
  :
    behaviors APFConfiguration.step c_tgt <1=
    behaviors PFConfiguration.step c_src.
Proof.
  i. ginduction PR; i.
  - econs 1. eapply sim_apf_pf_terminal; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 2; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 3; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 4; eauto.
Qed.

Theorem apf_pf_equiv s
  :
    behaviors APFConfiguration.step (Configuration.init s) <1=
    behaviors PFConfiguration.step (Configuration.init s).
Proof.
  eapply sim_apf_pf_adequacy.
  eapply sim_apf_pf_init; auto.
Qed.

Theorem apf_pf_equiv2 c
  :
    behaviors PFConfiguration.step c <1=
    behaviors APFConfiguration.step c.
Proof.
  eapply le_step_behavior_improve; eauto.
  i. eapply pfstep_apfstep; eauto.
Qed.


From iris.program_logic Require Import language ectxi_language ectx_language lifting.
From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.STLCmuST Require Import lang.

Section wkpre_lemmas.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuST_lang Σ}.

  Lemma wp_bind' (K : list ectx_item) s E e Φ :
    WP e @ s; E {{ v, WP fill K (of_val v) @ s; E {{ Φ }} }} ⊢ WP fill K e @ s; E {{ Φ }}.
  Proof. iApply wp_bind. Qed.

  Lemma wp_pure_step_later {s : stuckness} {E : coPset} e1 e2 Φ (H : pure_step e1 e2) :
    ▷ WP e2 @ s ; E {{Φ}} ⊢ WP e1 @ s ; E {{Φ}}.
  Proof. iIntros "He2". iApply (wp_pure_step_later _ _ _ _ True 1). intros t. by apply nsteps_once. auto. auto. Qed.

End wkpre_lemmas.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Projections.Round_Steps.States.
Require Export depoolContract.Scenarios.Common.RotateRoundsCondition.
Require Export depoolContract.Scenarios.Common.RoundDefinitions.
Require Export depoolContract.Scenarios.Common.unfreezeCondition.

Section Round_Steps_conditions.

Variable ticktockCalled : Prop.
Variable constructorCalled : Prop.
Variable terminatorCalled : Prop.
Variable onSuccessToRecoverStakeCalled : Prop.
Variable onFailToRecoverStakeCalled : Prop.
Variable onStakeRejectCalled : Prop.
Variable onStakeAcceptCalled : Prop.
Variable participateInElectionsCalled : Prop.
Variable completeRoundWithChunkCalled : Prop.
Variable queryId elector stakeAt chunkSize : Z.
Variable bounceExternal : Prop.
Variable functionId process_new_stakeId recover_stakeId decodedRoundId : Z.

Definition generateRoundCalled (l : Ledger) :=
    constructorCalled \/ rotate_round_conditions_full l ticktockCalled.

Definition projection_round_steps_constructor_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    generateRoundCalled l.

Definition projection_round_steps_constructor_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_PrePooling.

Definition projection_round_steps_constructor_fake0_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake0_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake0_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Pooling.

Definition projection_round_steps_constructor_fake1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake1_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_constructor_fake2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake2_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake2_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_prepool_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 < RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_prepool_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_prepool_completing_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_prepool_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 = RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_prepool_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_prepool_completed_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_prepool_pooling_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = roundPre0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling.

Definition projection_round_steps_prepool_pooling_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
        projection_round_steps_prepool_pooling_condition ol or /\
        roundIn nl nr /\
        getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Pooling.

Definition projection_round_steps_pooling_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 < RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_pooling_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_completing_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_pooling_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 = RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_pooling_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_completed_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_pooling_waiting_unfreeze_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    stakeSum (validatorStake l r) < m_validatorAssurance l.

Definition projection_round_steps_pooling_waiting_unfreeze_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_waiting_unfreeze_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_pooling_waiting_validator_request_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    m_validatorAssurance l <= stakeSum (validatorStake l r).

Definition projection_round_steps_pooling_waiting_validator_request_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_waiting_validator_request_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_completing1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest /\
    ownerOrSelfCall l /\
    poolClosed l = false.

Definition projection_round_steps_waiting_validator_request_completing1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_completing1_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_validator_request_completing2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_completing2_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_completing2_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    participateInElectionsCalled /\
    onlyValidatorContract l /\
    poolClosed l = false /\
    checkDePoolBalance l (msgValue l) (balance l) /\
    stakeAt = RoundsBase_ι_Round_ι_supposedElectedAt r /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = process_new_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    onStakeRejectCalled /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round1 l /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    onStakeAcceptCalled /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round1 l /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> currentValidator l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> prevValidator l /\
    validationStart l + RoundsBase_ι_Round_ι_stakeHeldFor r + ELECTOR_UNFREEZE_LAG l <= now l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_reward1_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_validator_start_waiting_reward2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> currentValidator l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> prevValidator l /\
    validationStart l + RoundsBase_ι_Round_ι_stakeHeldFor r + ELECTOR_UNFREEZE_LAG l <= now l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward2_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_reward2_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round1 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r = prevValidator l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = recover_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    (onSuccessToRecoverStakeCalled \/ onFailToRecoverStakeCalled) /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    roundIn l r /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r = RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_waiting_reward_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r = RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_waiting_reward_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_unfreeze_completing_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 < RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completing_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completing_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_unfreeze_completing_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 < RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completing_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completing_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_unfreeze_completed_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 = RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completed_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completed_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_waiting_unfreeze_completed_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 = RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completed_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completed_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_waiting_rewards_waiting_unfreeze_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = recover_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round2 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_rewards_waiting_unfreeze_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_rewards_waiting_unfreeze_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_rewards_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    (onSuccessToRecoverStakeCalled \/ onFailToRecoverStakeCalled) /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    roundIn l r /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_rewards_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_rewards_completing_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_completing_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    completeRoundWithChunkCalled /\
    selfCall l /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round2 l /\
    Z.of_nat (length (RoundsBase_ι_Round_ι_stakes r)) <= chunkSize /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_completing_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_completing_completed_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

End Round_Steps_conditions.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Require Import UFO.Lang.Sig.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Require Import UFO.Lang.StaticFacts.
Set Implicit Arguments.

Section section_ccompat_tm_op.

Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (N : it ∅ EV LV ∅ 𝕄) (E : eff ∅ EV LV ∅) (ℓ : lbl LV ∅).

Lemma ccompat_tm_op n ξ₁ ξ₂ t₁ t₂ :
n ⊨ 𝓣⟦ Ξ ⊢ (ty_it N ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ →
n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms (it_msig N) ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (tm_op t₁) (tm_op t₂).
Proof.
intro H.
change (tm_op t₁) with (ktx_plug (ktx_op ktx_hole) t₁).
change (tm_op t₂) with (ktx_plug (ktx_op ktx_hole) t₂).
eapply plug0 with (Ta := ty_it N ℓ).
+ intro ; simpl ; auto.
+ intro ; simpl ; auto.
+ iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
  iintro v₁ ; iintro v₂ ; iintro Hv.
  simpl ktx_plug.
  simpl 𝓥_Fun in Hv.
  idestruct Hv as m₁ Hv ; idestruct Hv as m₂ Hv.
  idestruct Hv as X₁ Hv ; idestruct Hv as X₂ Hv.
  idestruct Hv as Hv Hm ; idestruct Hm as HX Hm.
  ielim_prop Hv ; destruct Hv ; subst v₁ v₂.

  eapply 𝓣_step_r.
  { apply step_op. }
  eapply 𝓣_step_l.
  { apply step_op. }
  later_shift.

  apply 𝓥_unroll in Hm.
  apply 𝓥_in_𝓣.
  apply Hm.
+ apply postfix_refl.
+ apply postfix_refl.
+ apply H.
Qed.

End section_ccompat_tm_op.

Section section_compat_tm_op.
Context (n : nat).
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (N : it ∅ EV LV ∅ 𝕄) (E : eff ∅ EV LV ∅) (ℓ : lbl LV ∅).

Lemma compat_tm_op t₁ t₂ :
n ⊨ ⟦ Ξ Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_it N ℓ) # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (tm_op t₁) ≼ˡᵒᵍ (tm_op t₂) : (ty_ms (it_msig N) ℓ) # E ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl subst_tm.
apply ccompat_tm_op.
iespecialize Ht.
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
apply Ht.
Qed.

Lemma compat_ktx_op T' E' K₁ K₂ :
n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ : T' # E' ⇢ (ty_it N ℓ) # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (ktx_op K₁) ≼ˡᵒᵍ (ktx_op K₂) : T' # E' ⇢ (ty_ms (it_msig N) ℓ) # E⟧.
Proof.
intro HK.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro t₁ ; iintro t₂ ; iintro Ht.
iespecialize HK.
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ielim_vars HK ; [ | eassumption | eassumption ].
iespecialize HK.
ispecialize HK ; [ eassumption | ].
simpl ktx_plug.
apply ccompat_tm_op.
apply HK.
Qed.

End section_compat_tm_op.


Set Universe Polymorphism.
Module Foo.
  Definition T : sigT (fun x => x).
  Proof.
    exists Set.
    abstract exact nat.
  Defined.
End Foo.
Module Bar.
  Include Foo.
End Bar.
Definition foo := eq_refl : Foo.T = Bar.T.


Add Search Blacklist "Private_" "_subproof".
Set Printing Depth 50.
Remove Search Blacklist "Private_" "_subproof".
Add Search Blacklist "Private_" "_subproof".
Add LoadPath "../..".
Require Import BetaJulia.BasicPLDefs.Identifier.
Require Import BetaJulia.Sub0250a.BaseDefs.
Require Import BetaJulia.Sub0250a.BaseProps.
Require Import BetaJulia.Sub0250a.MatchProps.
Require Import BetaJulia.Sub0250a.SemSubProps.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Open Scope btjt_scope.
Open Scope btjm_scope.
Open Scope btjnf_scope.
Open Scope btjd_scope.
Lemma sub_d__inv_depth_le : forall t t' : ty, |- t << t' -> | t | <= | t' |.
Proof.
(intros t t' Hsub).
(induction Hsub).
-
constructor.
-
(apply Nat.le_trans with (| t2 |); assumption).
-
(simpl).
(apply Nat.max_le_compat; assumption).
-
(simpl).
(apply Nat.max_lub; assumption).
-
(simpl).
(apply Nat.le_max_l).
-
(simpl).
(apply Nat.le_max_r).
-
(simpl).
(rewrite max_baca_eq_bca).
constructor.
-
(simpl).
(rewrite max_abac_eq_abc).
constructor.
-
(simpl).
(apply le_n_S).
assumption.
Qed.
Lemma sub_d_eq__inv_depth_eq : forall t t' : ty, |- t << t' -> |- t' << t -> | t | = | t' |.
Proof.
(intros t t' Hsub1 Hsub2).
(apply Nat.le_antisymm; apply sub_d__inv_depth_le; assumption).
Qed.
Lemma unite_pairs__preserves_sub_d_l :
  forall t1 t2 t1' t2' : ty, |- t1 << t1' -> |- t2 << t2' -> |- unite_pairs t1 t2 << TPair t1' t2'.
Proof.
(intros ta; induction ta; intros tb;
  try (solve
   [ induction tb; intros ta' tb' Hsub1 Hsub2; try (solve [ simpl; constructor; assumption ]);
      destruct (sub_d_union_l__inv _ _ _ Hsub2) as [Hsub21 Hsub22]; rewrite unite_pairs_t_union; try resolve_not_union; constructor;
      [ apply IHtb1 | apply IHtb2 ]; assumption ])).
-
(intros ta' tb' Hsub1 Hsub2).
(apply sub_d_union_l__inv in Hsub1).
(destruct Hsub1 as [Hsub11 Hsub12]).
(rewrite unite_pairs_union_t).
(constructor; [ apply IHta1 | apply IHta2 ]; assumption).
Qed.
Lemma unite_pairs__preserves_sub_d_r :
  forall t1' t2' t1 t2 : ty, |- t1 << t1' -> |- t2 << t2' -> |- TPair t1 t2 << unite_pairs t1' t2'.
Proof.
(intros ta'; induction ta'; intros tb';
  try (solve
   [ induction tb'; intros ta tb Hsub1 Hsub2; try (solve [ simpl; constructor; assumption ]); rewrite unite_pairs_t_union;
      try resolve_not_union; apply SD_Trans with (TPair ta (TUnion tb'1 tb'2));
      [ constructor; constructor || assumption
      | apply SD_Trans with (TUnion (TPair ta tb'1) (TPair ta tb'2)); apply SD_Distr2 || apply SD_UnionL;
         [ apply union_right_1; apply IHtb'1 | apply union_right_2; apply IHtb'2 ]; assumption || constructor ] ])).
-
(intros ta tb Hsub1 Hsub2).
(rewrite unite_pairs_union_t).
(apply SD_Trans with (TPair (TUnion ta'1 ta'2) tb)).
+
(constructor; constructor || assumption).
+
(apply SD_Trans with (TUnion (TPair ta'1 tb) (TPair ta'2 tb))).
(apply SD_Distr1).
(apply SD_UnionL).
(apply union_right_1; apply IHta'1; assumption || constructor).
(apply union_right_2; apply IHta'2; assumption || constructor).
Qed.
Theorem mk_nf__sub_d_eq : forall t : ty, |- MkNF( t) << t /\ |- t << MkNF( t).
Proof.
(induction t).
-
(split; simpl; constructor).
-
(destruct IHt1; destruct IHt2).
(split; simpl).
(apply unite_pairs__preserves_sub_d_l; assumption).
(apply unite_pairs__preserves_sub_d_r; assumption).
-
(destruct IHt1; destruct IHt2).
(split; simpl; constructor; (apply union_right_1; assumption) || (apply union_right_2; assumption)).
-
(simpl).
(destruct IHt).
(split; constructor; assumption).
Qed.
Lemma mk_nf__sub_d_l : forall t : ty, |- MkNF( t) << t.
Proof.
(apply mk_nf__sub_d_eq).
Qed.
Lemma mk_nf__sub_d_r : forall t : ty, |- t << MkNF( t).
Proof.
(apply mk_nf__sub_d_eq).
Qed.
Lemma cname_sem_sub_k__sub_d :
  forall (k : nat) (c : cname), | TCName c | <= k -> forall t2 : ty, ||-[ k][TCName c]<= [t2] -> |- TCName c << t2.
Proof.
(intros k c Hdep t2).
(assert (Hva : value_type (TCName c)) by constructor).
(assert (Hma : |-[ k] TCName c <$ TCName c) by (apply match_ty_value_type__reflexive; assumption)).
(induction t2; intros Hsem; try (solve [ specialize (Hsem _ Hma); destruct k; simpl in Hsem; subst; constructor || contradiction ])).
-
(apply value_sem_sub_k_union__inv in Hsem; try assumption).
(destruct Hsem as [Hsem| Hsem]; [ apply union_right_1 | apply union_right_2 ]; tauto).
Qed.
Lemma pair_sem_sub_k__sub_d :
  forall (k : nat) (ta1 ta2 : ty),
  atom_type (TPair ta1 ta2) ->
  | TPair ta1 ta2 | <= k ->
  (forall tb1 : ty, ||-[ k][ta1]<= [tb1] -> |- ta1 << tb1) ->
  (forall tb2 : ty, ||-[ k][ta2]<= [tb2] -> |- ta2 << tb2) -> forall t2 : ty, ||-[ k][TPair ta1 ta2]<= [t2] -> |- TPair ta1 ta2 << t2.
Proof.
(intros k ta1 ta2 Hat Hdep IH1 IH2).
(assert (Hva : value_type (TPair ta1 ta2)) by (apply atom_type__value_type; assumption)).
(assert (Hma : |-[ k] TPair ta1 ta2 <$ TPair ta1 ta2) by (apply match_ty_value_type__reflexive; assumption)).
(induction t2; intros Hsem; try (solve [ specialize (Hsem _ Hma); destruct k; simpl in Hsem; subst; constructor || contradiction ])).
-
clear IHt2_1 IHt2_2.
(destruct (sem_sub_k_pair__inv _ _ _ _ _ Hdep Hsem) as [Hsem1 Hsem2]).
(constructor; [ apply IH1 | apply IH2 ]; tauto).
-
(apply value_sem_sub_k_union__inv in Hsem; try assumption).
(destruct Hsem as [Hsem| Hsem]; [ apply union_right_1 | apply union_right_2 ]; tauto).
Qed.
Lemma nf_sem_sub_k__sub_d : forall (k : nat) (t1 : ty), InNF( t1) -> | t1 | <= k -> forall t2 : ty, ||-[ k][t1]<= [t2] -> |- t1 << t2.
Proof.
(induction k;
  match goal with
  | |- forall t1 : ty, InNF( t1) -> | t1 | <= ?k -> forall t2 : ty, ||-[ ?k][t1]<= [t2] -> |- t1 << t2 =>
        apply
         (in_nf_mut (fun (t1 : ty) (_ : atom_type t1) => | t1 | <= k -> forall t2 : ty, ||-[ k][t1]<= [t2] -> |- t1 << t2)
            (fun (t1 : ty) (_ : in_nf t1) => | t1 | <= k -> forall t2 : ty, ||-[ k][t1]<= [t2] -> |- t1 << t2))
  end;
  try
   match goal with
   | |- context [ |- TCName _ << _ ] => apply cname_sem_sub_k__sub_d
   | |- context [ |- TPair _ _ << _ ] =>
         intros ta1 ta2 Hat1 IH1 Hat2 IH2 Hdep; assert (Hatp : atom_type (TPair ta1 ta2)) by (constructor; assumption);
          destruct (max_inv_depth_le__inv _ _ _ Hdep) as [Hdep1 Hdep2]; specialize (IH1 Hdep1); specialize
          (IH2 Hdep2); apply pair_sem_sub_k__sub_d; assumption
   | |- context [ |- TUnion _ _ << _ ] =>
         intros t1 t2 Hnf1 IH1 Hnf2 IH2 Hdep; destruct (max_inv_depth_le__inv _ _ _ Hdep) as [Hdep1 Hdep2]; intros t' Hsem;
          apply sem_sub_k_union_l__inv in Hsem; destruct Hsem as [Hsem1 Hsem2]; constructor; auto
   | |- forall ta : ty, atom_type ta -> _ => tauto
   end).
-
(intros t Hnft IHt Hdep).
(inversion Hdep).
-
(intros t Hnft IH).
(intros Hdep t2).
(assert (Hva : value_type (TRef t)) by constructor).
(assert (Hma : |-[ S k] TRef t <$ TRef t) by (apply match_ty_value_type__reflexive; assumption)).
(induction t2; intros Hsem; try (solve [ specialize (Hsem _ Hma); contradiction ])).
+
(apply value_sem_sub_k_union__inv in Hsem; try assumption).
(destruct Hsem as [Hsem| Hsem]; [ apply union_right_1 | apply union_right_2 ]; tauto).
+
clear IHt2.
(simpl in Hdep).
(pose proof (le_S_n _ _ Hdep) as Hdep').
(unfold sem_sub_k in Hsem).
specialize (Hsem _ Hma).
(apply match_ty_ref__inv in Hsem).
(destruct Hsem as [t' [Heqt' [[Hk Hdt't2] Href]]]).
(* Auto-generated comment: Succeeded. *)