(** OBS!: This is taken directly from Iris, and should instead be obtained
from bumping the Iris version. *)

(** Authoritative CMRA of append-only lists, where the fragment represents a
  snap-shot of the list, and the authoritative element can only grow by
  appending. *)
From iris.algebra Require Export auth dfrac max_prefix_list.
From iris.algebra Require Import updates local_updates proofmode_classes.
From iris.prelude Require Import options.

Definition mono_listR (A : ofe) : cmra  := authR (max_prefix_listUR A).
Definition mono_listUR (A : ofe) : ucmra  := authUR (max_prefix_listUR A).

Definition mono_list_auth {A : ofe} (q : dfrac) (l : list A) : mono_listR A :=
  ●{q} (to_max_prefix_list l) ⋅ ◯ (to_max_prefix_list l).
Definition mono_list_lb {A : ofe} (l : list A) : mono_listR A :=
  ◯ (to_max_prefix_list l).
Global Instance: Params (@mono_list_auth) 2 := {}.
Global Instance: Params (@mono_list_lb) 1 := {}.
Typeclasses Opaque mono_list_auth mono_list_lb.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Notation "●ML{ dq } l" :=
  (mono_list_auth dq l) (at level 20, format "●ML{ dq }  l").
Notation "●ML{# q } l" :=
  (mono_list_auth (DfracOwn q) l) (at level 20, format "●ML{# q }  l").
Notation "●ML□ l" := (mono_list_auth DfracDiscarded l) (at level 20).
Notation "●ML l" := (mono_list_auth (DfracOwn 1) l) (at level 20).
Notation "◯ML l" := (mono_list_lb l) (at level 20).

Section mono_list_props.
  Context {A : ofe}.
  Implicit Types l : list A.
  Implicit Types q : frac.
  Implicit Types dq : dfrac.

  (** Setoid properties *)
  Global Instance mono_list_auth_ne dq : NonExpansive (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_auth_proper dq : Proper ((≡) ==> (≡)) (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_ne : NonExpansive (@mono_list_lb A).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_proper : Proper ((≡) ==> (≡)) (@mono_list_lb A).
  Proof. solve_proper. Qed.

  Global Instance mono_list_lb_dist_inj n : Inj (dist n) (dist n) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.
  Global Instance mono_list_lb_inj : Inj (≡) (≡) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.

  (** * Operation *)
  Global Instance mono_list_lb_core_id l : CoreId (◯ML l).
  Proof. rewrite /mono_list_lb. apply _. Qed.
  Global Instance mono_list_auth_core_id l : CoreId (●ML□ l).
  Proof. rewrite /mono_list_auth. apply _. Qed.

  Lemma mono_list_auth_dfrac_op dq1 dq2 l :
    ●ML{dq1 ⋅ dq2} l ≡ ●ML{dq1} l ⋅ ●ML{dq2} l.
  Proof.
    rewrite /mono_list_auth auth_auth_dfrac_op.
    rewrite (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    by rewrite -core_id_dup (comm _ (◯ _)).
  Qed.

  Lemma mono_list_lb_op_l l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ⋅ ◯ML l2 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_l. Qed.
  Lemma mono_list_lb_op_r l1 l2 : l1 `prefix_of` l2 → ◯ML l2 ⋅ ◯ML l1 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_r. Qed.
  Lemma mono_list_auth_lb_op dq l : ●ML{dq} l ≡ ●ML{dq} l ⋅ ◯ML l.
  Proof.
    by rewrite /mono_list_auth /mono_list_lb -!assoc -auth_frag_op -core_id_dup.
  Qed.

  Global Instance mono_list_auth_dfrac_is_op dq dq1 dq2 l :
    IsOp dq dq1 dq2 → IsOp' (●ML{dq} l) (●ML{dq1} l) (●ML{dq2} l).
  Proof. rewrite /IsOp' /IsOp=> ->. rewrite mono_list_auth_dfrac_op //. Qed.

  (** * Validity *)
  Lemma mono_list_auth_dfrac_validN n dq l : ✓{n} (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_validN.
    naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_validN n l : ✓{n} (●ML l).
  Proof. by apply mono_list_auth_dfrac_validN. Qed.

  Lemma mono_list_auth_dfrac_valid dq l : ✓ (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_valid.
    naive_solver apply to_max_prefix_list_valid.
  Qed.
  Lemma mono_list_auth_valid l : ✓ (●ML l).
  Proof. by apply mono_list_auth_dfrac_valid. Qed.

  Lemma mono_list_auth_dfrac_op_validN n dq1 dq2 l1 l2 :
    ✓{n} (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡{n}≡ l2.
  Proof.
    rewrite /mono_list_auth (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    rewrite -auth_frag_op (comm _ (◯ _)) assoc. split.
    - move=> /cmra_validN_op_l /auth_auth_dfrac_op_validN.
      rewrite (inj_iff to_max_prefix_list). naive_solver.
    - intros [? ->]. rewrite -core_id_dup -auth_auth_dfrac_op auth_both_dfrac_validN.
      naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_op_validN n l1 l2 : ✓{n} (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_validN. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡ l2.
  Proof.
    rewrite cmra_valid_validN equiv_dist.
    setoid_rewrite mono_list_auth_dfrac_op_validN. naive_solver eauto using O.
  Qed.
  Lemma mono_list_auth_op_valid l1 l2 : ✓ (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_valid. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid_L `{!LeibnizEquiv A} dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 = l2.
  Proof. unfold_leibniz. apply mono_list_auth_dfrac_op_valid. Qed.

  Lemma mono_list_both_dfrac_validN n dq l1 l2 :
    ✓{n} (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc
      -auth_frag_op auth_both_dfrac_validN -to_max_prefix_list_includedN.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_includedN_r|done].
    - intros. split; [|by apply to_max_prefix_list_validN].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_validN n l1 l2 :
    ✓{n} (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_validN. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc -auth_frag_op
      auth_both_dfrac_valid -max_prefix_list_included_includedN
      -to_max_prefix_list_included.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_included_r|done].
    - intros. split; [|by apply to_max_prefix_list_valid].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_valid l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_valid. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid_L `{!LeibnizEquiv A} dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_dfrac_valid. naive_solver. Qed.
  Lemma mono_list_both_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_valid. naive_solver. Qed.

  Lemma mono_list_lb_op_validN n l1 l2 :
    ✓{n} (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡{n}≡ l1 ++ l) ∨ (∃ l, l1 ≡{n}≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_validN to_max_prefix_list_op_validN. Qed.
  Lemma mono_list_lb_op_valid l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡ l1 ++ l) ∨ (∃ l, l1 ≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_valid to_max_prefix_list_op_valid. Qed.
  Lemma mono_list_lb_op_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. rewrite mono_list_lb_op_valid / prefix. naive_solver. Qed.

  Lemma mono_list_lb_op_valid_1_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) → l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. by apply mono_list_lb_op_valid_L. Qed.
  Lemma mono_list_lb_op_valid_2_L `{!LeibnizEquiv A} l1 l2 :
    l1 `prefix_of` l2 ∨ l2 `prefix_of` l1 → ✓ (◯ML l1 ⋅ ◯ML l2).
  Proof. by apply mono_list_lb_op_valid_L. Qed.

  Lemma mono_list_lb_mono l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ≼ ◯ML l2.
  Proof. intros. exists (◯ML l2). by rewrite mono_list_lb_op_l. Qed.

  Lemma mono_list_included dq l : ◯ML l ≼ ●ML{dq} l.
  Proof. apply cmra_included_r. Qed.

  (** * Update *)
  Lemma mono_list_update {l1} l2 : l1 `prefix_of` l2 → ●ML l1 ~~> ●ML l2.
  Proof. intros ?. by apply auth_update, max_prefix_list_local_update. Qed.
  Lemma mono_list_auth_persist dq l : ●ML{dq} l ~~> ●ML□ l.
  Proof.
    rewrite /mono_list_auth. apply cmra_update_op; [|done].
    by apply auth_update_auth_persist.
  Qed.
End mono_list_props.

Definition mono_listURF (F : oFunctor) : urFunctor :=
  authURF (max_prefix_listURF F).

Global Instance mono_listURF_contractive F :
  oFunctorContractive F → urFunctorContractive (mono_listURF F).
Proof. apply _. Qed.

Definition mono_listRF (F : oFunctor) : rFunctor :=
  authRF (max_prefix_listURF F).

Global Instance mono_listRF_contractive F :
  oFunctorContractive F → rFunctorContractive (mono_listRF F).
Proof. apply _. Qed.


From iris.program_logic Require Import lifting.
From iris.algebra Require Import frac dec_agree gmap list.
From iris.base_logic Require Import big_op auth.
From iris_logrel.F_mu_ref Require Export rules.
From iris.proofmode Require Import tactics.
Import uPred.

Definition specN := nroot .@ "spec".

(** The CMRA for the heap of the specification. *)
Definition cfgUR := prodUR (optionUR (exclR exprC)) heapUR.

(** The CMRA for the thread pool. *)
Class cfgSG Σ :=
  CFGSG { ctg_heapG :> heapG Σ; cfg_inG :> authG Σ cfgUR; cfg_name : gname }.

Section definitionsS.
  Context `{cfgSG Σ}.

  Definition heapS_mapsto (l : loc) (q : Qp) (v: val) : iProp Σ :=
    own cfg_name (◯ (∅, {[ l := (q, DecAgree v) ]})).

  Definition tpool_mapsto (e: expr) : iProp Σ :=
    own cfg_name (◯ (Excl' e, ∅)).

  Definition spec_inv (ρ : cfg lang) : iProp Σ :=
    (∃ e σ, own cfg_name (● (Excl' e , to_heap σ)) ∗ ■ rtc step ρ ([e],σ))%I.
  Definition spec_ctx (ρ : cfg lang) : iProp Σ :=
    inv specN (spec_inv ρ).

  Global Instance heapS_mapsto_timeless l q v : TimelessP (heapS_mapsto l q v).
  Proof. apply _. Qed.
  Global Instance spec_ctx_persistent ρ : PersistentP (spec_ctx ρ).
  Proof. apply _. Qed.
End definitionsS.
Typeclasses Opaque heapS_mapsto tpool_mapsto.

Notation "l ↦ₛ{ q } v" := (heapS_mapsto l q v)
  (at level 20, q at level 50, format "l  ↦ₛ{ q }  v") : uPred_scope.
Notation "l ↦ₛ v" := (heapS_mapsto l 1 v) (at level 20) : uPred_scope.
Notation "⤇ e" := (tpool_mapsto e) (at level 20) : uPred_scope.

Section cfg.
  Context `{cfgSG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.
  Implicit Types σ : state.
  Implicit Types g : heapUR.
  Implicit Types e : expr.
  Implicit Types v : val.

  (** Conversion to tpools and back *)
  Lemma step_insert_no_fork K e σ e' σ' :
    head_step e σ e' σ' [] → step ([fill K e], σ) ([fill K e'], σ').
  Proof. intros Hst. eapply (step_atomic _ _ _ _ _ _ [] [] []); eauto.
         by apply: Ectx_step'.
  Qed.

  Lemma step_pure E ρ K e e' :
    (∀ σ, head_step e σ e' σ []) →
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K e ={E}=∗ ⤇ fill K e'.
  Proof.
    iIntros (??) "[#Hspec Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as ">Hinv" "Hclose". iDestruct "Hinv" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
       (exclusive_local_update _ (Excl (fill K e'))). }
    iFrame "Hj". iApply "Hclose". iNext. iExists (fill K e'), σ.
    iFrame. iPureIntro. eapply rtc_r, step_insert_no_fork; eauto.
  Qed.

  Lemma step_alloc E ρ K e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Alloc e) ={E}=∗ ∃ l, ⤇ fill K (Loc l) ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "[#Hinv Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    destruct (exist_fresh (dom (gset positive) σ)) as [l Hl%not_elem_of_dom].
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
       (exclusive_local_update _ (Excl (fill K (Loc l)))). }
    iMod (own_update with "Hown") as "[Hown Hl]".
    { eapply auth_update_alloc, prod_local_update_2,
        (alloc_singleton_local_update _ l (1%Qp,DecAgree v)); last done.
      by apply lookup_to_heap_None. }
    iExists l. rewrite /heapS_mapsto. iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K (Loc l)), (<[l:=v]>σ).
    rewrite to_heap_insert; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_load E ρ K l q v:
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Load (Loc l)) ∗ l ↦ₛ{q} v
    ={E}=∗ ⤇ fill K (of_val v) ∗ l ↦ₛ{q} v.
  Proof.
    iIntros (?) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iDestruct (own_valid_2 _ with "Hown Hl")
      as %[[_ ?%heap_singleton_included]%prod_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
        (exclusive_local_update _ (Excl (fill K (of_val v)))). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K (of_val v)), σ.
    iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_store E ρ K l v' e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Store (Loc l) e) ∗ l ↦ₛ v'
    ={E}=∗ ⤇ fill K Unit ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iDestruct (own_valid_2 _ with "Hown Hl")
      as %[[_ Hl%heap_singleton_included]%prod_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
        (exclusive_local_update _ (Excl (fill K Unit))). }
    iMod (own_update_2 with "Hown Hl") as "[Hown Hl]".
    { eapply auth_update, prod_local_update_2, singleton_local_update,
        (exclusive_local_update _ (1%Qp, DecAgree v)); last done.
      by rewrite /to_heap lookup_fmap Hl. }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K Unit), (<[l:=v]>σ).
    rewrite to_heap_insert; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_lam E ρ K e1 e2 v :
    to_val e2 = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (App (Lam e1) e2)
    ={E}=∗ ⤇ fill K (e1.[e2/]).
  Proof. intros ?; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_tlam E ρ K e :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (TApp (TLam e)) ={E}=∗ ⤇ fill K e.
  Proof. apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_Fold E ρ K e v :
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Unfold (Fold e)) ={E}=∗ ⤇ fill K e.
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_fst E ρ K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Fst (Pair e1 e2)) ={E}=∗ ⤇ fill K e1.
  Proof. intros H1 H2; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_snd E ρ K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Snd (Pair e1 e2)) ={E}=∗ ⤇ fill K e2.
  Proof. intros H1 H2; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_case_inl E ρ K e0 v0 e1 e2 :
    to_val e0 = Some v0 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Case (InjL e0) e1 e2)
      ={E}=∗ ⤇ fill K (e1.[e0/]).
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_case_inr E ρ K e0 v0 e1 e2 :
    to_val e0 = Some v0 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Case (InjR e0) e1 e2)
      ={E}=∗ ⤇ fill K (e2.[e0/]).
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

End cfg.


Require Import VerifiedVerifier.Machine.
Require Import VerifiedVerifier.Maps.
Require Import VerifiedVerifier.Safety.
Require Import Coq.Init.Nat.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import VerifiedVerifier.BinaryLattice.
Require Import VerifiedVerifier.AbstractAnalysis.
Require Import VerifiedVerifier.Semantics.
Require Import Lia.

(* TODO: Don't really know how to encode this*)
(*
Definition function_safety (f : function_ty) :=
*)

Definition program_safety (p : program_ty) : Prop :=
  forall fuel,
    (fst (run_program_stream p fuel)).(error) = false.

(* NOTE: This probably isn't a useful definition *)
(*
Definition function_safety (p : program_ty) (f : function_ty) : Prop :=
  forall fuel s,
    s.(error) = false ->
    (run_function p f s fuel).(error) = false.
*)

Theorem program_maintains_error :
  forall s,
    s.(error) = true ->
    forall p cfg n fuel,
      (run_program' p cfg n s fuel).(error) = true.
Proof.
  intros. induction fuel.
  simpl. assumption.
  simpl. destruct (next_node cfg s n).
  - admit.
  - admit.
Admitted.

Theorem program_stream_maintains_error :
  forall p fuel,
    (fst (run_program_stream p fuel)).(error) = true ->
    (fst (run_program_stream p (S fuel))).(error) = true.
Proof.
  admit.
Admitted.

Definition function_safety (f : function_ty) : Prop :=
  forall f cfg p n s fuel,
    well_formed_program p ->
    s.(error) = false ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (run_program' p cfg n s fuel).(error) = false.

Theorem well_formed_find_edge_ret :
  forall cfg n p f ,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (last (fst n) Ret) = Ret ->
    forall b,
      find_edge cfg n b = None.
Proof.
  admit.
Admitted.

Theorem well_formed_find_edge_branch :
  forall cfg n p f c,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (last (fst n) Ret) = Branch c ->
    exists n' n'',
      find_edge cfg n True_Branch = Some n' /\
      find_edge cfg n False_Branch = Some n'' /\
      find_edge cfg n Non_Branch = None.
Proof.
  admit.
Admitted.

(* TODO: Might have to change how the conditional is handled *)
Theorem well_formed_find_edge_non_branch :
  forall cfg n p f c,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
      (last (fst n) Ret) <> Ret ->
      (last (fst n) Ret) <> Branch c ->
      exists n',
        find_edge cfg n True_Branch = None /\
        find_edge cfg n False_Branch = None /\
        find_edge cfg n Non_Branch = Some n'.
Proof.
  admit.
Admitted.

Theorem verified_function_lookup :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel r hd_i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Indirect_Call r ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

(* NOTE: shouldn't even need to run the verifier for this one, just well-formedness *)
Theorem verified_function_call :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i f_name,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Direct_Call f_name ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_heap_read :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r_dst r_src r_base,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Heap_Read r_dst r_src r_base ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_heap_write :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r_dst r_val r_base,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Heap_Write r_dst r_val r_base ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.
Proof.

Theorem verified_stack_contract :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Contract i ->
      (run_instr p hd_i.(instr) s).(error) = false.
  admit.
Admitted.

Theorem verified_stack_read :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Read r i ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_stack_write :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i i r,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Write i r ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verify_get_instrs_till_terminal :
  forall cfg n fuel p f,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    snd (get_instrs_till_terminal cfg n fuel) <> error_return.
Proof.
  intros. unfold get_instrs_till_terminal.
  induction fuel. unfold snd. discriminate.
  fold get_instrs_till_terminal. fold get_instrs_till_terminal in IHfuel.
  assert ((fst n) <> nil). unfold well_formed_program in H. destruct H. destruct H3. destruct H4. destruct H5.
  - specialize H6 with f. apply H6 in H0. unfold well_formed_fun in H0. unfold well_formed_cfg in H0.
    destruct H0. destruct H7. destruct H8. unfold non_empty_nodes in H8. specialize H8 with n. symmetry in H1.
    rewrite H1 in H8. apply H8. apply H2.
  - admit.
    (* case (last (fst n) Ret); intros. *)
Admitted.

Theorem verify_get_next_instrs :
  forall p cfg n i s fuel,
    well_formed_program p ->
    exists f,
      In f p.(fun_list) ->
      cfg = fst f ->
      In n cfg.(nodes) ->
      In i (fst n) ->
      verify_program p = true ->
      snd (get_next_instrs p cfg n i s fuel) <> error_return.
Proof.
  admit.
Admitted.

Theorem run_program_stream_equiv :
  forall p istream s fuel s' istream',
    well_formed_program p ->
    (s', istream') = run_program_stream' p istream s fuel ->
    fst (run_program_stream' p istream s (S fuel)) = fst (run_program_stream' p istream' s' 1).
Proof.
  admit.
Admitted.

Theorem function_safety_run :
  forall p s fuel,
    well_formed_program p ->
    verify_program p = true ->
    s = run_program_stream p fuel ->
    (fst s).(error) = false ->
    (fst (run_program_stream p (S fuel))).(error) = false.
Proof.
  intros. unfold run_program_stream.
  admit.
Admitted.

(* TODO: find official lemmas for these *)
Lemma distribute_fst {A : Type} {B : Type} :
  forall (c : bool) (x: A) (y : A) (a : B) (b : B),
    fst (if c then (x, a) else (y, b)) = if c then x else y.
Proof.
  intros. case c; auto.
Qed.

Lemma error_set_exit :
  forall s,
    s.(error) = (set_exit_state s).(error).
Proof.
  auto.
Qed.

Lemma distribute_error :
  forall (c : bool) s s',
    error (if c then s else s') = if c then (error s) else (error s').
Proof.
  intros. case c; auto.
Qed.

Lemma if_eq :
  forall (A : Type) (c : bool) (a : A),
    (if c then a else a) = a.
Proof.
  intros. case c; auto.
Qed.

Lemma tuple_eq :
  forall (x : (state * list instr_data)),
    (fst x, snd x) = x.
Proof.
  intros. destruct x. simpl. auto.
Qed.

(* TODO: Generalize these *)
Lemma tuple_eq' :
  forall (x y : (state * list instr_data)),
    x = y ->
    fst x = fst y /\ snd x = snd y.
Proof.
  intros.
  pose proof surjective_pairing as H1. specialize H1 with state (list instr_data) x.
  rewrite H1 in H. destruct y. inversion H. rewrite H2. rewrite H3.
  unfold fst. unfold snd. auto.
Qed.

Lemma tuple_split :
  forall (a : state) (b : list instr_data) (x : (state * list instr_data)),
    (a, b) = x ->
    a = fst x /\ b = snd x.
Proof.
  intros. destruct x. pose proof tuple_eq'.
  specialize H0 with (a, b) (s, l). apply H0 in H. inversion H.
  split; auto.
Qed.

Lemma tuple_ret_eq' :
  forall (x y : (list instr_data * return_state)),
    x = y ->
    fst x = fst y /\ snd x = snd y.
Proof.
  intros.
  pose proof surjective_pairing as H1. specialize H1 with (list instr_data) return_state x.
  rewrite H1 in H. destruct y. inversion H. rewrite H2. rewrite H3.
  unfold fst. unfold snd. auto.
Qed.

Lemma tuple_ret_split :
  forall (a : list instr_data) (b : return_state) (x : (list instr_data * return_state)),
    (a, b) = x ->
    a = fst x /\ b = snd x.
Proof.
  intros. destruct x. pose proof tuple_ret_eq'.
  specialize H0 with (a, b) (l, r). apply H0 in H. inversion H.
  split; auto.
Qed.

Lemma prog_stream_eq :
  forall p fuel start_stream,
    snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) = normal_return ->
    fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) = start_stream ->
    run_program_stream p fuel = run_program_stream' p start_stream (start_state p) fuel.
Proof.
  intros. unfold run_program_stream.
  remember (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) as g.
  destruct g. pose proof tuple_ret_split.
  specialize H1 with l r (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel).
  apply H1 in Heqg. inversion Heqg. simpl in H. simpl in H0. rewrite H. rewrite H0. reflexivity.
Qed.

Theorem function_safety_run_other :
  forall p s istream fuel start_stream s',
    well_formed_program p ->
    verify_program p = true ->
    (snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)) = normal_return ->
    start_stream = (fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)) ->
    (s, istream) = run_program_stream' p start_stream (start_state p) fuel ->
    s.(error) = false ->
    s' = fst (run_program_stream' p start_stream (start_state p) (S fuel)) ->
    s'.(error) = false.
Proof.
  intros. assert (Hwell := H).
  pose proof run_program_stream_equiv as Hequiv.
  specialize Hequiv with p start_stream (start_state p) fuel s istream.
  apply Hequiv in H.
  - rewrite H in H5. rewrite H5. induction istream.
    + unfold run_program_stream'.
      case (error s || exit s)%bool. assumption. assumption.
    + unfold run_program_stream'. case (error s || exit s)%bool. assumption.
      destruct (get_next_instrs p (cfg a) (node a) (instr a) s 1).
      destruct r. auto. admit.
      remember (run_instr p (instr a) s) as s''.

      assert ((fst (if (error s'' || exit s'')%bool
                        then (s'', l ++ istream)
                        else (set_exit_state s'', l ++ istream))) =
                  (if (error s'' || exit s'')%bool
                   then s''
                   else set_exit_state s'')) as Hdist.
      case (error s'' || exit s'')%bool; auto.

      rewrite Hdist.
      pose proof distribute_error as Herr.
      specialize Herr with (error s'' || exit s'')%bool s'' (set_exit_state s'').
      rewrite Herr.
      pose proof error_set_exit as Hexit. specialize Hexit with s''. symmetry in Hexit.
      rewrite Hexit.
      pose proof if_eq as Hif. specialize Hif with bool (error s'' || exit s'')%bool (error s'').
      rewrite Hif. rewrite Heqs''.
      remember (instr a) as instr_a.
      destruct instr_a; auto.
      * pose proof verified_heap_read as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r r0 r1.
        assert (instr a = Heap_Read r r0 r1). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_heap_write as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r r0 r1.
        assert (instr a = Heap_Write r r0 r1). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * simpl. destruct (function_lookup p (get_register s r)); auto.
      * pose proof verified_stack_contract as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a n.
        assert (instr a = Stack_Contract n). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_stack_read as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r n.
        assert (instr a = Stack_Read r n). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_stack_write as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a n r.
        assert (instr a = Stack_Write n r). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
  - assumption.
Admitted.

Theorem get_instrs_till_terminal_ret :
  forall cfg n fuel,
    snd (get_instrs_till_terminal cfg n fuel) = normal_return ->
    get_instrs_till_terminal cfg n fuel = get_instrs_till_terminal cfg n (S fuel).
Proof.
  admit.
Admitted.

Theorem verified_program :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    program_safety p.
Proof.
  intros. unfold program_safety. intros. unfold run_program_stream.
  pose proof verify_get_instrs_till_terminal as Hterminal.
  specialize Hterminal with (fst (main p)) (start_node (fst (main p))) fuel p (main p).
  assert (snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) <> error_return).
  apply Hterminal; auto.
  unfold well_formed_program in H. destruct H. destruct H1. destruct H2. destruct H3. assumption.
  unfold well_formed_program in H. destruct H. destruct H1. destruct H2. destruct H3.
  specialize H4 with (main p). apply H4 in H3. unfold well_formed_fun in H3.
  unfold well_formed_cfg in H3. destruct H3. destruct H5. destruct H6. assumption.

  destruct (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) eqn:Htest.
  (*
  assert (l = fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)). admit.
  assert (r = snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)). admit.
  *)
  (* TODO: I don't know why the context forgets this information *)
  unfold snd in H1. destruct r. auto. contradiction.
  induction fuel.
  simpl. reflexivity.
  pose proof function_safety_run_other as Hstream'.
  remember (run_program_stream' p l (start_state p) fuel) as s.
  remember (run_program_stream' p l (start_state p) (S fuel)) as s'.
  specialize Hstream' with p (fst (run_program_stream' p l (start_state p) fuel)) (snd s) fuel l (fst s').
  pose proof get_instrs_till_terminal_ret as Hget. (*assert (r = normal_return). admit.*)
  specialize Hget with (fst (main p)) (start_node (fst (main p))) fuel. symmetry in Hget.
  apply Hstream'; auto.
  - rewrite Hget. admit. admit.
  - rewrite Hget. admit. admit.
  - pose proof tuple_eq as Htup. specialize Htup with (run_program_stream' p l (start_state p) fuel).
    rewrite Heqs. rewrite Htup. auto.
  - admit.
  - pose proof tuple_eq' as Htup'. specialize Htup' with s' (run_program_stream' p l (start_state p) (S fuel)).
    apply Htup' in Heqs'. inversion Heqs'. assumption.
Admitted.

(* NOTE: old version *)
(*
Theorem verified_program :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    program_safety p.
Proof.
  intros. unfold program_safety. intros. unfold run_program.
  unfold run_program'. induction fuel.
  simpl. reflexivity. fold run_program'. fold run_program' in IHfuel.
  destruct (next_node (fst (main p)) (start_state p) (start_node (fst (main p)))).
  -
    + destruct (last (fst (start_node (fst (main p)))) Ret). unfold run_basic_block.
  -

  induction p.(fun_list).
  - unfold run_program'. induction fuel.
    + simpl. reflexivity.
    + destruct (next_node (fst (main p)) (start_state p) (start_node (fst (main p)))).
      *
*)


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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import LowerPromises.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.

Set Implicit Arguments.

Lemma read_step_cur_future
      lc1 mem1 loc val released ord lc2
      (WF1: Local.wf lc1 mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (READ: Local.read_step lc1 mem1 loc ((TView.cur (Local.tview lc1)).(View.rlx) loc) val released ord lc2):
  <<PROMISES: (Local.promises lc1) = (Local.promises lc2)>> /\
  <<TVIEW_RLX: (TView.cur (Local.tview lc1)).(View.rlx) = (TView.cur (Local.tview lc2)).(View.rlx)>> /\
  <<TVIEW_PLN: forall l (LOC: l <> loc),
      (TView.cur (Local.tview lc1)).(View.pln) l = (TView.cur (Local.tview lc2)).(View.pln) l>>.
Proof.
  destruct lc1 as [tview1 promises1]. inv READ. ss.
  esplits; eauto.
  - condtac; ss; try by destruct ord.
    apply TimeMap.antisym.
    + etrans; [|apply TimeMap.join_l]. apply TimeMap.join_l.
    + apply TimeMap.join_spec; auto using TimeMap.bot_spec.
      apply TimeMap.join_spec; try refl.
      unfold View.singleton_ur_if. condtac; ss.
      * ii. unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; try apply Time.bot_spec.
        subst. refl.
      * ii. unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; try apply Time.bot_spec.
        subst. refl.
  - i. condtac; ss; try by destruct ord.
    unfold TimeMap.join, TimeMap.bot.
    rewrite TimeFacts.le_join_l; try apply Time.bot_spec.
    rewrite TimeFacts.le_join_l; ss.
    etrans; [|apply Time.bot_spec].
    unfold View.singleton_ur_if. condtac; ss; try refl.
    unfold TimeMap.singleton, LocFun.add, LocFun.init. condtac; ss. refl.
Qed.

Lemma fence_step_future
      lc1 sc1 ordr ordw lc2 sc2
      (ORDR: Ordering.le ordr Ordering.relaxed)
      (ORDW: Ordering.le ordw Ordering.acqrel)
      (FENCE: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
  <<PROMISES: (Local.promises lc1) = (Local.promises lc2)>> /\
  <<TVIEW: (TView.cur (Local.tview lc1)) = (TView.cur (Local.tview lc2))>>.
Proof.
  destruct lc1 as [tview1 promises1]. inv FENCE. split; ss.
  condtac; try by destruct ordw.
  condtac; try by destruct ordr.
Qed.

Lemma write_step_consistent
      lc1 sc1 mem1
      loc val ord
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1))
      (CONS1: Local.promise_consistent lc1):
  exists from to released lc2 sc2 mem2 kind,
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val None released ord lc2 sc2 mem2 kind>> /\
    <<CONS2: Local.promise_consistent lc2>>.
Proof.
  destruct (classic (exists f t m, Memory.get loc t (Local.promises lc1) = Some (f, m) /\
                              m <> Message.reserve)).
  { des.
    exploit Memory.min_concrete_ts_exists; eauto. i. des.
    exploit Memory.min_concrete_ts_spec; eauto. i. des.
    exploit Memory.get_ts; try exact GET. i. des.
    { subst. inv WF1. rewrite BOT in *. ss. }
    clear f t m H H0 MIN.
    exploit progress_write_step_split; try exact GET; eauto.
    { ss. unfold TimeMap.bot. apply Time.bot_spec. }
    i. des.
    esplits; eauto. ii.
    assert (TS: loc0 = loc -> Time.le ts ts0).
    { i. subst. inv x2. inv WRITE. inv PROMISE0. ss.
      revert PROMISE.
      erewrite Memory.remove_o; eauto. condtac; ss. des; ss.
      erewrite Memory.split_o; eauto. repeat condtac; ss; i.
      - des; ss. subst. refl.
      - des; ss.
        exploit Memory.min_concrete_ts_spec; try exact PROMISE; eauto. i. des. ss. }
    inv x2. inv WRITE. inv PROMISE0. ss.
    unfold TimeMap.join, TimeMap.singleton.
    unfold LocFun.add, LocFun.init, LocFun.find.
    condtac; ss.
    - subst. apply TimeFacts.join_spec_lt.
      + eapply TimeFacts.lt_le_lt; try eapply TS; eauto.
      + eapply TimeFacts.lt_le_lt; try eapply TS; eauto.
        apply Time.middle_spec. ss.
    - revert PROMISE.
      erewrite Memory.remove_o; eauto. condtac; ss.
      erewrite Memory.split_o; eauto. repeat condtac; ss; try by des; ss.
      guardH o. guardH o0. guardH o1. i.
      apply TimeFacts.join_spec_lt; eauto.
      destruct (TimeFacts.le_lt_dec ts0 Time.bot); ss.
      inv l; inv H.
      inv WF1. rewrite BOT in *. ss.
  }
  { exploit progress_write_step; eauto.
    { apply Time.incr_spec. }
    i. des.
    esplits; eauto. ii.
    inv x0. inv WRITE. inv PROMISE0. ss.
    revert PROMISE.
    erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite Memory.add_o; eauto. condtac; ss. i.
    destruct (Loc.eq_dec loc0 loc).
    - subst. exfalso. apply H; eauto.
    - unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      apply TimeFacts.join_spec_lt; eauto.
      destruct (TimeFacts.le_lt_dec ts Time.bot); ss.
      inv l; inv H0.
      inv WF1. rewrite BOT in *. ss.
  }
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition complete_mmio_emulation_spec0 (rec: Pointer) (adt: RData) : option (RData * Z) :=
    match rec with
    | (_rec_base, _rec_ofst) =>
      when' _t'7 == get_rec_run_is_emulated_mmio_spec  adt;
      rely is_int64 _t'7;
      if (_t'7 =? 0) then
        Some (adt, 1)
      else
        when' _esr == get_rec_last_run_info_esr_spec (_rec_base, _rec_ofst) adt;
        rely is_int64 _esr;
        when _rt == esr_srt_spec (VZ64 _esr) adt;
        rely is_int _rt;
        rely is_int64 (Z.land _esr 4227858432);
        if (negb ((Z.land _esr 4227858432) =? 2415919104)) then
          let _t'6 := 1 in
          Some (adt, 0)
        else
          rely is_int64 (Z.land _esr 16777216);
          let _t'6 := ((Z.land _esr 16777216) =? 0) in
          if _t'6 then
            Some (adt, 0)
          else
            when _t'3 == esr_is_write_spec (VZ64 _esr) adt;
            rely is_int _t'3;
            if (_t'3 =? 0) then
              let _t'4 := (negb (_rt =? 31)) in
              if _t'4 then
                when adt == emulate_mmio_read_spec (VZ64 _esr) _rt (_rec_base, _rec_ofst) adt;
                when' _t'5 == get_rec_pc_spec (_rec_base, _rec_ofst) adt;
                rely is_int64 _t'5;
                rely is_int64 (_t'5 + 4);
                when adt == set_rec_pc_spec (_rec_base, _rec_ofst) (VZ64 (_t'5 + 4)) adt;
                Some (adt, 1)
              else
                when' _t'5 == get_rec_pc_spec (_rec_base, _rec_ofst) adt;
                rely is_int64 _t'5;
                rely is_int64 (_t'5 + 4);
                when adt == set_rec_pc_spec (_rec_base, _rec_ofst) (VZ64 (_t'5 + 4)) adt;
                Some (adt, 1)
            else
              let _t'4 := 0 in
              when' _t'5 == get_rec_pc_spec (_rec_base, _rec_ofst) adt;
              rely is_int64 _t'5;
              rely is_int64 (_t'5 + 4);
              when adt == set_rec_pc_spec (_rec_base, _rec_ofst) (VZ64 (_t'5 + 4)) adt;
              Some (adt, 1)
     end
    .

End SpecLow.


Require Import VerdiRaft.Raft.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.

Require Import VerdiRaft.AppendEntriesReplySublogInterface.
Require Import VerdiRaft.SortedInterface.

Require Import VerdiRaft.NextIndexSafetyInterface.

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

  Context {aersi : append_entries_reply_sublog_interface}.
  Context {si : sorted_interface}.

  Lemma nextIndex_safety_init :
    raft_net_invariant_init nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_init, nextIndex_safety.
    intros.
    discriminate.
  Qed.

  Definition nextIndex_preserved st st' :=
    (type st' = Leader ->
     type st = Leader /\
     maxIndex (log st) <= maxIndex (log st') /\
     nextIndex st' = nextIndex st).

  Lemma nextIndex_safety_preserved :
    forall st st',
      (forall h',
          type st = Leader ->
          Nat.pred (getNextIndex st h') <= maxIndex (log st)) ->
      nextIndex_preserved st st' ->
      (forall h',
          type st' = Leader ->
          Nat.pred (getNextIndex st' h') <= maxIndex (log st')).
  Proof using.
    unfold getNextIndex, nextIndex_preserved in *.
    intuition.
    repeat find_rewrite.
    auto.
    unfold assoc_default in *.
    specialize (H h').
    break_match.
    - eauto using Nat.le_trans.
    - lia.
  Qed.

  Theorem handleClientRequest_nextIndex_preserved :
    forall h st client id c out st' ps,
      handleClientRequest h st client id c = (out, st', ps) ->
      nextIndex_preserved st st'.
  Proof using.
    unfold handleClientRequest, nextIndex_preserved.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; try congruence.
    intuition.
  Qed.

  Lemma nextIndex_safety_client_request :
    raft_net_invariant_client_request nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_client_request, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, handleClientRequest_nextIndex_preserved.
    - auto.
  Qed.

  Lemma handleTimeout_nextIndex_preserved :
    forall h d out d' l,
      handleTimeout h d = (out, d', l) ->
      nextIndex_preserved d d'.
  Proof using.
    unfold handleTimeout, tryToBecomeLeader, nextIndex_preserved.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; try congruence.
    auto.
  Qed.

  Lemma nextIndex_safety_timeout :
    raft_net_invariant_timeout nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_timeout, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, handleTimeout_nextIndex_preserved.
    - auto.
  Qed.

  Lemma handleAppendEntries_nextIndex_preserved :
    forall h st t n pli plt es ci st' ps,
      handleAppendEntries h st t n pli plt es ci = (st', ps) ->
      nextIndex_preserved st st'.
  Proof using.
    unfold handleAppendEntries, nextIndex_preserved, advanceCurrentTerm.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; try congruence; auto.
  Qed.

  Lemma nextIndex_safety_append_entries :
    raft_net_invariant_append_entries nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_append_entries, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, handleAppendEntries_nextIndex_preserved.
    - auto.
  Qed.

  Lemma handleAppendEntriesReply_nextIndex :
    forall h st st' m t es res h',
      handleAppendEntriesReply h st h' t es res = (st', m) ->
      type st' = Leader ->
      type st = Leader /\
      ((nextIndex st' = nextIndex st \/
       (res = true /\
        currentTerm st = t /\
        nextIndex st' =
        (assoc_set name_eq_dec (nextIndex st) h'
                   (Nat.max (getNextIndex st h') (S (maxIndex es)))))) \/
      (res = false /\
       currentTerm st = t /\
       nextIndex st' =
        (assoc_set name_eq_dec (nextIndex st) h'
                   (pred (getNextIndex st h'))))).
  Proof using.
    unfold handleAppendEntriesReply, advanceCurrentTerm.
    intros.
    repeat break_match; repeat find_inversion; do_bool; simpl in *; intuition; congruence.
  Qed.

  Lemma nextIndex_safety_append_entries_reply :
    raft_net_invariant_append_entries_reply nextIndex_safety.
  Proof using si aersi.
    unfold raft_net_invariant_append_entries_reply, nextIndex_safety, getNextIndex.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - erewrite handleAppendEntriesReply_log by eauto.
      find_copy_apply_lem_hyp handleAppendEntriesReply_nextIndex; auto.
      intuition; repeat find_rewrite.
      + auto.
      + destruct (name_eq_dec h' (pSrc p)).
        * subst. rewrite get_set_same_default.
          unfold getNextIndex.
          apply Nat.max_case; auto.
          { destruct es; simpl.
            * lia.
            * pose proof append_entries_reply_sublog_invariant _ ltac:(eauto).
              unfold append_entries_reply_sublog in *.
              eapply_prop_hyp pBody pBody; simpl; eauto.
              apply maxIndex_is_max; auto.
              apply logs_sorted_invariant; auto.
          }
        * rewrite get_set_diff_default by auto.
          auto.
      + destruct (name_eq_dec h' (pSrc p)).
        * subst. rewrite get_set_same_default.
          unfold getNextIndex.
          apply NPeano.Nat.le_le_pred.
          auto.
        * rewrite get_set_diff_default by auto.
          auto.
    - auto.
  Qed.

  Lemma handleRequestVote_nextIndex_preserved :
    forall st h h' t lli llt st' m,
      handleRequestVote h st t h' lli llt = (st', m) ->
      nextIndex_preserved st st'.
  Proof using.
    unfold handleRequestVote, nextIndex_preserved, advanceCurrentTerm.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto; try congruence.
  Qed.

  Lemma nextIndex_safety_request_vote :
    raft_net_invariant_request_vote nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_request_vote, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, handleRequestVote_nextIndex_preserved.
    - auto.
  Qed.

  Lemma handleRequestVoteReply_matchIndex :
    forall n st src t v,
      type (handleRequestVoteReply n st src t v) = Leader ->
      type st = Leader /\
      nextIndex (handleRequestVoteReply n st src t v) =
      nextIndex st \/
      nextIndex (handleRequestVoteReply n st src t v) = [].
  Proof using.
    unfold handleRequestVoteReply.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto; try congruence.
  Qed.

  Lemma nextIndex_safety_request_vote_reply :
    raft_net_invariant_request_vote_reply nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_request_vote_reply, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - find_copy_apply_lem_hyp handleRequestVoteReply_matchIndex.
      unfold getNextIndex in *.
      erewrite handleRequestVoteReply_log in * by eauto.
      intuition; repeat find_rewrite.
      + auto.
      + unfold assoc_default. simpl.
        auto using NPeano.Nat.le_le_pred.
    - auto.
  Qed.

  Lemma doLeader_nextIndex_preserved :
        forall st h os st' ms,
      doLeader st h = (os, st', ms) ->
      nextIndex_preserved st st'.
  Proof using.
    unfold doLeader, nextIndex_preserved.
    intros.
    repeat break_match; repeat find_inversion; auto; try congruence.
  Qed.

  Lemma nextIndex_safety_do_leader :
    raft_net_invariant_do_leader nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_do_leader, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, doLeader_nextIndex_preserved.
    - auto.
  Qed.

  Lemma doGenericServer_nextIndex_preserved :
    forall h st os st' ms,
      doGenericServer h st = (os, st', ms) ->
      nextIndex_preserved st st'.
  Proof using.
    unfold doGenericServer, nextIndex_preserved.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto; try congruence;
    use_applyEntries_spec; subst; simpl in *; auto.
  Qed.

  Lemma nextIndex_safety_do_generic_server :
    raft_net_invariant_do_generic_server nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_do_generic_server, nextIndex_safety.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - eauto using nextIndex_safety_preserved, doGenericServer_nextIndex_preserved.
    - auto.
  Qed.

  Lemma nextIndex_safety_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset, nextIndex_safety.
    simpl.
    intros.
    repeat find_reverse_higher_order_rewrite.
    auto.
  Qed.

  Lemma nextIndex_safety_reboot :
    raft_net_invariant_reboot nextIndex_safety.
  Proof using.
    unfold raft_net_invariant_reboot, nextIndex_safety, reboot.
    simpl.
    intros.
    subst.
    repeat find_higher_order_rewrite.
    update_destruct_simplify.
    - unfold getNextIndex, assoc_default. simpl. lia.
    - auto.
  Qed.

  Lemma nextIndex_safety_invariant :
    forall net,
      raft_intermediate_reachable net ->
      nextIndex_safety net.
  Proof using si aersi.
    intros.
    apply raft_net_invariant; auto.
    - apply nextIndex_safety_init.
    - apply nextIndex_safety_client_request.
    - apply nextIndex_safety_timeout.
    - apply nextIndex_safety_append_entries.
    - apply nextIndex_safety_append_entries_reply.
    - apply nextIndex_safety_request_vote.
    - apply nextIndex_safety_request_vote_reply.
    - apply nextIndex_safety_do_leader.
    - apply nextIndex_safety_do_generic_server.
    - apply nextIndex_safety_state_same_packet_subset.
    - apply nextIndex_safety_reboot.
  Qed.

  Instance nisi : nextIndex_safety_interface.
  Proof.
    split.
    exact nextIndex_safety_invariant.
  Qed.
End NextIndexSafety.


From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine Require Export logrel.
From cap_machine.ftlr Require Export ftlr_base.
From cap_machine.rules Require Export rules_Get rules_base.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.
  Notation D := ((leibnizO Word) -n> iPropO Σ).
  Notation R := ((leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  Lemma get_case (r : leibnizO Reg) (p : Perm)
        (b e a : Addr) (w : Word) (dst r0 : RegName) (ins: instr) (P:D) :
    is_Get ins dst r0 →
    ftlr_instr r p b e a w ins P.
  Proof.
    intros Hinstr Hp Hsome i Hbae Hi.
    iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    rewrite <- Hi in Hinstr. clear Hi.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_Get with "[$Ha $Hmap]"); eauto.
    { simplify_map_eq; auto. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec; cycle 1.
    { iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext.
      iIntros "_".
      iApply wp_value; auto. iIntros; discriminate. }
    { incrementPC_inv; simplify_map_eq.
      iApply wp_pure_step_later; auto. iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro]. iNext.
      assert (dst <> PC) as HdstPC by (intros ->; simplify_map_eq).
      iIntros "_".
      simplify_map_eq.
      iApply ("IH" $! (<[dst := _]> (<[PC := _]> r)) with "[%] [] [Hmap] [$Hown]");
        try iClear "IH"; eauto.
      { intro. cbn. by repeat (rewrite lookup_insert_is_Some'; right). }
      iIntros (ri v Hri Hsv). rewrite insert_commute // lookup_insert_ne // in Hsv; [].
      destruct (decide (ri = dst)); simplify_map_eq.
      { repeat rewrite fixpoint_interp1_eq; auto. }
      { by iApply "Hreg". } rewrite !fixpoint_interp1_eq /=. destruct Hp as [-> | ->];iFrame "Hinv". }
  Qed.

End fundamental.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import CRelationClasses.
From Equations.Type Require Import Relation Relation_Properties.
From MetaCoq.Template Require Import config utils BasicAst.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
     PCUICLiftSubst PCUICEquality PCUICUnivSubst
     PCUICReduction.

Set Default Goal Selector "!".

(** * Definition of cumulativity and conversion relations *)

Reserved Notation " Σ ;;; Γ |- t <=[ pb ] u" (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  |-  t  <=[ pb ] u").

Definition leq_term_ext `{checker_flags} (Σ : global_env_ext) Rle t u := eq_term_upto_univ Σ (eq_universe Σ) Rle t u.

Notation " Σ ⊢ t <===[ pb ] u" := (compare_term pb Σ Σ t u) (at level 50, t, u at next level).

(** ** Cumulativity *)

Inductive cumulAlgo_gen `{checker_flags} (Σ : global_env_ext) (Γ : context) (pb : conv_pb) : term -> term -> Type :=
| cumul_refl t u : Σ ⊢ t <===[ pb ] u -> Σ ;;; Γ |- t <=[pb] u
| cumul_red_l t u v : Σ ;;; Γ |- t ⇝ v -> Σ ;;; Γ |- v <=[pb] u -> Σ ;;; Γ |- t <=[pb] u
| cumul_red_r t u v : Σ ;;; Γ |- t <=[pb] v -> Σ ;;; Γ |- u ⇝ v -> Σ ;;; Γ |- t <=[pb] u
where " Σ ;;; Γ |- t <=[ pb ] u " := (cumulAlgo_gen Σ Γ pb t u) : type_scope.

Notation " Σ ;;; Γ |- t = u " := (cumulAlgo_gen Σ Γ Conv t u) (at level 50, Γ, t, u at next level) : type_scope.
Notation " Σ ;;; Γ |- t <= u " := (cumulAlgo_gen Σ Γ Cumul t u) (at level 50, Γ, t, u at next level) : type_scope.

Notation cumulAlgo Σ Γ := (cumulAlgo_gen Σ Γ Cumul).
Notation convAlgo Σ Γ := (cumulAlgo_gen Σ Γ Conv).

#[global]
Hint Resolve cumul_refl : pcuic.

Include PCUICConversion.

Module PCUICConversionParAlgo <: EnvironmentTyping.ConversionParSig PCUICTerm PCUICEnvironment PCUICTermUtils PCUICEnvTyping.
  Definition cumul_gen := @cumulAlgo_gen.
End PCUICConversionParAlgo.

#[global]
Instance cumul_pb_decls_refl {cf:checker_flags} pb Σ Γ Γ' : Reflexive (cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ').
Proof.
  intros x. destruct x as [na [b|] ty]; constructor; auto.
  all:constructor; reflexivity.
Qed.

#[global]
Instance conv_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (conv_decls cumulAlgo_gen Σ Γ Γ') := _.
#[global]
Instance cumul_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (cumul_decls cumulAlgo_gen Σ Γ Γ') := _.

Lemma cumul_alt `{cf : checker_flags} Σ Γ t u :
  Σ ;;; Γ |- t <= u <~> { v & { v' & (red Σ Γ t v * red Σ Γ u v' *
  leq_term_ext Σ (leq_universe Σ) v v')%type } }.
Proof.
  split.
  - induction 1.
    + exists t, u. intuition auto.
    + destruct IHX as (v' & v'' & (redv & redv') & leqv).
      exists v', v''. intuition auto. now eapply red_step.
    + destruct IHX as (v' & v'' & (redv & redv') & leqv).
      exists v', v''. intuition auto. now eapply red_step.
  - intros [v [v' [[redv redv'] Hleq]]].
    apply clos_rt_rt1n in redv.
    apply clos_rt_rt1n in redv'.
    induction redv.
    * induction redv'.
    ** constructor; auto.
    ** econstructor 3; eauto.
    * econstructor 2; eauto.
Qed.

#[global]
Instance cumul_refl' {cf:checker_flags} Σ Γ pb : Reflexive (cumulAlgo_gen Σ Γ pb).
Proof.
  intro; constructor; reflexivity.
Qed.

#[global]
Instance conv_refl' {cf:checker_flags} Σ Γ : Reflexive (convAlgo Σ Γ).
Proof.
  intro; constructor. unfold leq_term_ext. reflexivity.
Qed.

Lemma red_cumul `{cf : checker_flags} {Σ : global_env_ext} {Γ t u} :
  red Σ Γ t u ->
  Σ ;;; Γ |- t <= u.
Proof.
  intros. apply clos_rt_rt1n in X.
  induction X.
  - reflexivity.
  - econstructor 2. all: eauto.
Qed.

Lemma red_cumul_inv `{cf : checker_flags} {Σ : global_env_ext} {Γ t u} :
  red Σ Γ t u ->
  Σ ;;; Γ |- u <= t.
Proof.
  intros. apply clos_rt_rt1n in X.
  induction X.
  - reflexivity.
  - econstructor 3. all: eauto.
Qed.

Lemma red_cumul_cumul `{cf : checker_flags} {Σ : global_env_ext} {Γ t u v} :
  red Σ Γ t u -> Σ ;;; Γ |- u <= v -> Σ ;;; Γ |- t <= v.
Proof.
  intros. apply clos_rt_rt1n in X.
  induction X. 1: auto.
  econstructor 2; eauto.
Qed.

Lemma red_cumul_cumul_inv `{cf : checker_flags} {Σ : global_env_ext} {Γ t u v} :
  red Σ Γ t v -> Σ ;;; Γ |- u <= v -> Σ ;;; Γ |- u <= t.
Proof.
  intros. apply clos_rt_rt1n in X.
  induction X. 1: auto.
  econstructor 3.
  - eapply IHX. eauto.
  - eauto.
Qed.

Lemma conv_cumul2 {cf:checker_flags} Σ Γ t u :
  Σ ;;; Γ |- t = u -> (Σ ;;; Γ |- t <= u) * (Σ ;;; Γ |- u <= t).
Proof.
  induction 1.
  - split; constructor; now apply eq_term_leq_term.
  - destruct IHX as [H1 H2]. split.
    * econstructor 2; eassumption.
    * econstructor 3; eassumption.
  - destruct IHX as [H1 H2]. split.
    * econstructor 3; eassumption.
    * econstructor 2; eassumption.
Qed.

Lemma conv_cumul {cf:checker_flags} Σ Γ t u :
  Σ ;;; Γ |- t = u -> Σ ;;; Γ |- t <= u.
Proof.
  intro H; now apply conv_cumul2 in H.
Qed.

Lemma conv_cumul_inv {cf:checker_flags} Σ Γ t u :
  Σ ;;; Γ |- u = t -> Σ ;;; Γ |- t <= u.
Proof.
  intro H; now apply conv_cumul2 in H.
Qed.

Lemma red_conv {cf:checker_flags} (Σ : global_env_ext) Γ t u
  : red Σ Γ t u -> Σ ;;; Γ |- t = u.
Proof.
  intros H%clos_rt_rt1n_iff.
  induction H.
  - reflexivity.
  - econstructor 2; eauto.
Qed.

#[global]
Hint Resolve red_conv : core.

Lemma eq_term_App `{checker_flags} Σ φ f f' :
  eq_term Σ φ f f' ->
  isApp f = isApp f'.
Proof.
  inversion 1; reflexivity.
Qed.

Lemma eq_term_eq_term_napp {cf:checker_flags} Σ ϕ napp t t' :
  eq_term Σ ϕ t t' ->
  eq_term_upto_univ_napp Σ (eq_universe ϕ) (eq_universe ϕ) napp t t'.
Proof.
  intros. eapply eq_term_upto_univ_impl. 5:eauto.
  4:auto with arith. all:typeclasses eauto.
Qed.

Lemma leq_term_leq_term_napp {cf:checker_flags} Σ ϕ napp t t' :
  leq_term Σ ϕ t t' ->
  eq_term_upto_univ_napp Σ (eq_universe ϕ) (leq_universe ϕ) napp t t'.
Proof.
  intros. eapply eq_term_upto_univ_impl. 5:eauto.
  4:auto with arith. all:typeclasses eauto.
Qed.

Lemma eq_term_mkApps `{checker_flags} Σ φ f l f' l' :
  eq_term Σ φ f f' ->
  All2 (eq_term Σ φ) l l' ->
  eq_term Σ φ (mkApps f l) (mkApps f' l').
Proof.
  induction l in l', f, f' |- *; intro e; inversion_clear 1.
  - assumption.
  - cbn. eapply IHl.
    + constructor; auto. now apply eq_term_eq_term_napp.
    + assumption.
Qed.

Lemma leq_term_App `{checker_flags} Σ φ f f' :
  leq_term Σ φ f f' ->
  isApp f = isApp f'.
Proof.
  inversion 1; reflexivity.
Qed.

Lemma leq_term_mkApps `{checker_flags} Σ φ f l f' l' :
  leq_term Σ φ f f' ->
  All2 (eq_term Σ φ) l l' ->
  leq_term Σ φ (mkApps f l) (mkApps f' l').
Proof.
  induction l in l', f, f' |- *; intro e; inversion_clear 1.
  - assumption.
  - cbn. apply IHl.
    + constructor; try assumption.
      now eapply leq_term_leq_term_napp.
    + assumption.
Qed.

#[global]
Hint Resolve cumul_refl' : core.

Lemma red_conv_conv `{cf : checker_flags} Σ Γ t u v :
  red (fst Σ) Γ t u -> Σ ;;; Γ |- u = v -> Σ ;;; Γ |- t = v.
Proof.
  intros. apply clos_rt_rt1n_iff in X.
  induction X; auto.
  now econstructor 2.
Qed.

Lemma red_conv_conv_inv `{cf : checker_flags} Σ Γ t u v :
  red (fst Σ) Γ t u -> Σ ;;; Γ |- v = u -> Σ ;;; Γ |- v = t.
Proof.
  intros X%clos_rt_rt1n_iff.
  induction X; auto.
  now econstructor 3; [eapply IHX|]; eauto.
Qed.

#[global]
Instance conv_sym `{cf : checker_flags} (Σ : global_env_ext) Γ :
  Symmetric (convAlgo Σ Γ).
Proof.
  intros t u X. induction X.
  - symmetry in c; now constructor.
  - eapply red_conv_conv_inv.
    + eapply red1_red in r. eauto.
    + eauto.
  - eapply red_conv_conv.
    + eapply red1_red in r. eauto.
    + eauto.
Qed.

Lemma conv_alt_red {cf : checker_flags} {Σ : global_env_ext} {Γ : context} {t u : term} :
  Σ;;; Γ |- t = u <~> (∑ v v' : term, (red Σ Γ t v × red Σ Γ u v') ×
    eq_term Σ (global_ext_constraints Σ) v v').
Proof.
  split.
  - induction 1.
    * exists t, u; intuition auto.
    * destruct IHX as [? [? [? ?]]].
      exists x, x0; intuition auto. eapply red_step; eauto.
    * destruct IHX as [? [? [? ?]]].
      exists x, x0; intuition auto. eapply red_step; eauto.
  - destruct 1 as [? [? [[? ?] ?]]].
    eapply red_conv_conv; eauto.
    eapply red_conv_conv_inv; eauto. now constructor.
Qed.

Definition eq_termp_napp {cf:checker_flags} (pb: conv_pb) (Σ : global_env_ext) napp :=
  compare_term_napp pb Σ Σ napp.

Notation eq_termp pb Σ := (compare_term pb Σ Σ).

Lemma eq_term_eq_termp {cf:checker_flags} pb (Σ : global_env_ext) x y :
  eq_term Σ Σ x y ->
  eq_termp pb Σ x y.
Proof.
  destruct pb; [easy|].
  cbn.
  apply eq_term_upto_univ_leq; auto.
  typeclasses eauto.
Qed.

Lemma cumul_App_l {cf:checker_flags} :
  forall {Σ Γ f g x},
    Σ ;;; Γ |- f <= g ->
    Σ ;;; Γ |- tApp f x <= tApp g x.
Proof.
  intros Σ Γ f g x h.
  induction h.
  - eapply cumul_refl. constructor.
    + apply leq_term_leq_term_napp. assumption.
    + reflexivity.
  - eapply cumul_red_l ; try eassumption.
    econstructor. assumption.
  - eapply cumul_red_r ; try eassumption.
    econstructor. assumption.
Qed.

Section ContextConversion.
  Context {cf : checker_flags}.
  Context (Σ : global_env_ext).

  Notation conv_context Γ Γ' := (All2_fold (conv_decls cumulAlgo_gen Σ) Γ Γ').
  Notation cumul_context Γ Γ' := (All2_fold (cumul_decls cumulAlgo_gen Σ) Γ Γ').

  Global Instance conv_ctx_refl : Reflexive (All2_fold (conv_decls cumulAlgo_gen Σ)).
  Proof using Type.
    intro Γ; induction Γ; try econstructor; auto.
    destruct a as [na [b|] ty]; constructor; auto; pcuic; eapply conv_refl'.
  Qed.

  Global Instance cumul_ctx_refl : Reflexive (All2_fold (cumul_decls cumulAlgo_gen Σ)).
  Proof using Type.
    intro Γ; induction Γ; try econstructor; auto.
    destruct a as [na [b|] ty];
     econstructor; eauto; pcuic; try eapply conv_refl'; eapply cumul_refl'.
  Qed.

  Definition conv_ctx_refl' Γ : conv_context Γ Γ
  := conv_ctx_refl Γ.

  Definition cumul_ctx_refl' Γ : cumul_context Γ Γ
    := cumul_ctx_refl Γ.

End ContextConversion.


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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryMerge.
  Lemma add_lower_add
        mem0 loc from to msg1 msg2 mem1 mem2
        (ADD1: Memory.add mem0 loc from to msg1 mem1)
        (LOWER2: Memory.lower mem1 loc from to msg1 msg2 mem2):
    Memory.add mem0 loc from to msg2 mem2.
  Proof.
    inv ADD1. inv ADD. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.add in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
  Qed.

  Lemma split_lower_split
        mem0 loc ts1 ts2 ts3 msg2 msg2' msg3 mem1 mem2
        (SPLIT1: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem1)
        (LOWER2: Memory.lower mem1 loc ts1 ts2 msg2 msg2' mem2):
    Memory.split mem0 loc ts1 ts2 ts3 msg2' msg3 mem2.
  Proof.
    inv SPLIT1. inv SPLIT. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.split in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
  Qed.

  Lemma lower_lower_lower
        mem0 loc from to msg0 msg1 msg2 mem1 mem2
        (LOWER1: Memory.lower mem0 loc from to msg0 msg1 mem1)
        (LOWER2: Memory.lower mem1 loc from to msg1 msg2 mem2):
    Memory.lower mem0 loc from to msg0 msg2 mem2.
  Proof.
    inv LOWER1. inv LOWER. inv LOWER2. inv LOWER.
    rewrite LocFun.add_add_eq. econs; auto.
    unfold Cell.lower in *.
    destruct r, r0. ss. subst.
    unfold LocFun.add. condtac; [|congr]. s.
    rewrite DOMap.add_add_eq. econs; auto.
    etrans; eauto.
  Qed.

  Lemma promise_promise_promise
        loc from to msg1 msg2 promises0 promises1 promises2 mem0 mem1 mem2 kind
        (PROMISE1: Memory.promise promises0 mem0 loc from to msg1 promises1 mem1 kind)
        (PROMISE2: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1)):
    Memory.promise promises0 mem0 loc from to msg2 promises2 mem2 kind.
  Proof.
    inv PROMISE2. inv PROMISE1.
    - econs; eauto.
      + eapply add_lower_add; eauto.
      + eapply add_lower_add; eauto.
      + des. subst. eauto.
    - econs; eauto.
      + eapply split_lower_split; eauto.
      + eapply split_lower_split; eauto.
      + des. subst.
        exploit Memory.lower_get0; eauto. i. des.
        inv MSG_LE. eauto.
    - econs; eauto.
      + eapply lower_lower_lower; eauto.
      + eapply lower_lower_lower; eauto.
    - exploit Memory.remove_get0; try exact PROMISES0. i. des.
      exploit Memory.lower_get0; try exact PROMISES. i. des.
      congr.
  Qed.

  Lemma promise_write_write
        loc from to msg1 val released promises0 promises1 promises2 mem0 mem1 mem2 kind
        (PROMISE1: Memory.promise promises0 mem0 loc from to msg1 promises1 mem1 kind)
        (PROMISE2: Memory.write promises1 mem1 loc from to val released promises2 mem2 (Memory.op_kind_lower msg1)):
    Memory.write promises0 mem0 loc from to val released promises2 mem2 kind.
  Proof.
    inv PROMISE2.
    exploit promise_promise_promise; try exact PROMISE1; eauto.
  Qed.

  Lemma add_remove
        loc from to msg mem0 mem1 mem2
        (ADD1: Memory.add mem0 loc from to msg mem1)
        (REMOVE2: Memory.remove mem1 loc from to msg mem2):
    mem0 = mem2.
  Proof.
    apply Memory.ext. i. symmetry.
    exploit Memory.add_get0; eauto. i. des.
    erewrite Memory.remove_o; eauto. condtac; ss.
    - des. subst. rewrite GET. ss.
    - guardH o.
      erewrite Memory.add_o; eauto. condtac; ss; eauto.
  Qed.
End MemoryMerge.


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

Require Import VST.floyd.printf.
Require Import ITree.Eq.

#[export] Instance nat_id : FileId := { file_id := nat; stdin := 0%nat; stdout := 1%nat }.
#[export] Instance file_struct : FileStruct := {| FILEid := ___sFILE64; reent := __reent; f_stdin := __stdin; f_stdout := __stdout |}.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog (write_list stdout
       (string2bytes "Hello, world!
");; write_list stdout (string2bytes "This is line 2.
"))%itree gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=
   (*ltac:(with_library prog *)(ltac:(make_printf_specs prog) ++ [ main_spec ])(*)*).

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
make_stdio.
repeat do_string2bytes.
repeat (sep_apply data_at_to_cstring; []).
sep_apply (has_ext_ITREE(E := @IO_event file_id)).

forward_printf tt (write_list stdout (string2bytes "This is line 2.
")).
{ rewrite !sepcon_assoc; apply sepcon_derives; cancel.
  apply derives_refl. }
forward_call.
forward.
forward_fprintf outp ((Ers, string2bytes "line", gv ___stringlit_2), (Int.repr 2, tt)) (stdout, Ret tt : @IO_itree (@IO_event file_id)).
{ rewrite 3sepcon_assoc, sepcon_comm, sepcon_assoc; apply sepcon_derives; cancel.
  rewrite bind_ret'; apply derives_refl. }
forward.
Qed.


(** * Grothendieck Construction of a functor to Cat *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Pseudofunctor.Core Pseudofunctor.FromFunctor.
Require Import Cat.Core.
Require Import Grothendieck.PseudofunctorToCat.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Funext}.

  Variable P : PreCategory -> Type.
  (*Context `{forall C, IsHProp (P C)}.*)
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P HF).

  Variable C : PreCategory.
  Variable F : Functor C cat.

  (** ** Category of elements *)
  Definition category : PreCategory
    := category (pseudofunctor_of_functor_to_cat F).

  (** ** First projection functor *)
  Definition pr1 : Functor category C
    := pr1 (pseudofunctor_of_functor_to_cat F).
End Grothendieck.


Require Import PeanoNat Lia List.
Require Import Common FMap IndexSupport.
Require Import Syntax Semantics SemFacts StepM Invariant.
Require Import Serial SerialFacts.
Require Import Reduction Commutativity QuasiSeq Topology.
Require Import RqRsTopo RqRsFacts.
Require Import RqRsInvMsg RqRsInvLock RqRsInvAtomic RqRsInvSep.
Require Import RqUpRed RsUpRed RqRsRed.

Set Implicit Arguments.

Open Scope list.
Open Scope fmap.

Section RqDownReduction.
  Context `{dv: DecValue} `{oifc: OStateIfc}.
  Variables (dtr: DTree)
            (sys: System).

  Hypotheses (Hiorqs: GoodORqsInit (initsOf sys))
             (oinvs: IdxT -> ObjInv)
             (Hrrs: RqRsSys dtr sys oinvs).

  Section OnRqDown.
    Variables (cidx: IdxT) (pobj: Object)
              (rqDowns: list (Id Msg)).
    Hypotheses (Hrqd: RqDownMsgs dtr sys cidx rqDowns)
               (Hpobj: In pobj sys.(sys_objs))
               (Hcp: parentIdxOf dtr cidx = Some (obj_idx pobj)).

    Lemma rqDown_oinds:
      forall hst inits ins outs eouts,
        SubList rqDowns eouts ->
        Atomic inits ins hst outs eouts ->
        forall st1 st2,
          Reachable (steps step_m) sys st1 ->
          steps step_m sys st1 hst st2 ->
          DisjList (oindsOf hst) (subtreeIndsOf dtr cidx).
    Proof.
      intros.
      destruct Hrqd as [cobj [[rqDown rqdm] ?]]; dest; subst; simpl in *.
      eapply atomic_rqDown_covers with (rqDown0:= (rqDown, rqdm)); eauto.
      - red; auto.
      - apply SubList_singleton_In; auto.
    Qed.

    Lemma rqDown_olast_inside_tree:
      forall inits ins hst outs eouts,
        DisjList rqDowns inits ->
        Atomic inits ins hst outs eouts ->
        forall st1 st2 loidx,
          Reachable (steps step_m) sys st1 ->
          Forall (InMPI st1.(st_msgs)) rqDowns ->
          steps step_m sys st1 hst st2 ->
          lastOIdxOf hst = Some loidx ->
          In loidx (subtreeIndsOf dtr cidx) ->
          SubList (oindsOf hst) (subtreeIndsOf dtr cidx).
    Proof.
      intros.
      destruct Hrqd as [cobj [[rqDown rqdm] ?]]; dest; subst; simpl in *.
      inv H2; clear H12.
      pose proof H0.
      eapply rqUp_start_ok in H2; eauto.
      destruct H2 as [ruhst [nhst ?]]; dest; subst.
      assert (~ In (rqDown, rqdm) inits).
      { eapply DisjList_In_2; [eassumption|].
        left; reflexivity.
      }
      clear H.

      destruct H6; subst.
      - rewrite app_nil_r in *.
        eapply atomic_NonRqUp_rqDown_separation_inside
          with (cobj0:= cobj) (pobj0:= pobj) (rqDown0:= (rqDown, rqdm)); eauto.
        eapply lastOIdxOf_Some_oindsOf_In; eauto.

      - destruct H as [roidx [rqUps [ruins [ruouts ?]]]]; dest.
        pose proof H.
        destruct H14 as [cidx [rqUp [? _]]]; subst.
        destruct H13; subst.
        + simpl in *; clear H10.
          eapply rqUp_atomic_lastOIdxOf in H4; eauto; [|right; eauto].
          dest; eapply rqUp_atomic_bounded; eauto.
          right; auto.
        + destruct H13 as [nins [nouts ?]]; dest.
          rewrite oindsOf_app.
          eapply steps_split in H3; [|reflexivity].
          destruct H3 as [sti [? ?]].

          assert (SubList (oindsOf nhst) (subtreeIndsOf dtr (obj_idx cobj))).
          { eapply atomic_NonRqUp_rqDown_separation_inside
              with (cobj0:= cobj) (pobj0:= pobj)
                   (rqDown0:= (rqDown, rqdm)) (s1:= sti) (ioidx:= loidx); eauto.
            { eapply atomic_messages_in_in; try eapply H6; eauto. }
            { intro Hx; apply H12 in Hx.
              eapply atomic_rqDown_inits_outs_disj
                with (cidx0:= obj_idx cobj) (rqDown0:= (rqDown, rqdm))
                     (hst:= nhst ++ ruhst); eauto.
              eapply steps_append; eauto.
            }
            { eapply lastOIdxOf_Some_oindsOf_In; eauto.
              rewrite lastOIdxOf_app in H4; [|intro Hx; subst; inv H13].
              assumption.
            }
          }
          apply SubList_app_3; [assumption|].
          apply H16 in H14.
          apply subtreeIndsOf_SubList in H14; [|apply Hrrs].
          eapply SubList_trans; [|eapply H14].
          eapply rqUp_atomic_inside_tree; eauto.
          * discriminate.
          * right; auto.
    Qed.

    Lemma rqDown_olast_outside_tree:
      forall inits ins hst outs eouts,
        DisjList rqDowns inits ->
        Atomic inits ins hst outs eouts ->
        forall st1 st2 loidx,
          Reachable (steps step_m) sys st1 ->
          Forall (InMPI st1.(st_msgs)) rqDowns ->
          steps step_m sys st1 hst st2 ->
          lastOIdxOf hst = Some loidx ->
          ~ In loidx (subtreeIndsOf dtr cidx) ->
          exists ruhst nhst,
            hst = nhst ++ ruhst /\
            (ruhst = nil \/
             exists roidx rqUps ruins ruouts,
               RqUpMsgsP dtr roidx rqUps /\
               ~ In roidx (subtreeIndsOf dtr cidx) /\
               Atomic inits ruins ruhst ruouts rqUps /\
               SubList rqUps outs /\
               (nhst = nil \/
                exists nins nouts,
                  Atomic rqUps nins nhst nouts eouts)) /\
            DisjList (oindsOf nhst) (subtreeIndsOf dtr cidx).
    Proof.
      intros.
      destruct Hrqd as [cobj [[rqDown rqdm] ?]]; dest; subst; simpl in *.
      inv H2; clear H12.
      pose proof H0.
      eapply rqUp_start_ok in H2; eauto.
      destruct H2 as [ruhst [nhst ?]]; dest; subst.
      exists ruhst, nhst.
      assert (~ In (rqDown, rqdm) inits).
      { eapply DisjList_In_2; [eassumption|].
        left; reflexivity.
      }
      clear H.

      destruct H6; subst.
      - rewrite app_nil_r in *.
        repeat ssplit; [reflexivity|left; reflexivity|].
        eapply atomic_NonRqUp_rqDown_separation_outside
          with (cobj0:= cobj) (pobj0:= pobj) (rqDown0:= (rqDown, rqdm))
               (ioidx:= loidx); eauto.
        eapply lastOIdxOf_Some_oindsOf_In; eauto.

      - destruct H as [roidx [rqUps [ruins [ruouts ?]]]]; dest.
        pose proof H.
        destruct H14 as [cidx [rqUp [? _]]]; subst rqUps.
        destruct H13; subst.
        + simpl in *; clear H10.
          repeat ssplit; [reflexivity| |apply DisjList_nil_1].
          right; exists roidx, [rqUp], ruins, ruouts.
          repeat ssplit; try assumption.
          * eapply rqUp_atomic_lastOIdxOf in H6; eauto; [|right; eauto].
            dest; eapply outside_parent_out; try apply Hrrs; eauto.
          * left; reflexivity.

        + destruct H13 as [nins [nouts ?]]; dest.
          assert (DisjList (oindsOf nhst) (subtreeIndsOf dtr (obj_idx cobj))).
          { eapply steps_split in H3; [|reflexivity].
            destruct H3 as [sti [? ?]].
            eapply atomic_NonRqUp_rqDown_separation_outside
              with (cobj0:= cobj) (pobj0:= pobj) (rqDown0:= (rqDown, rqdm))
                   (ioidx:= loidx) (s1:= sti); eauto.
            { eapply atomic_messages_in_in; try eapply H6; eauto. }
            { intro Hx; apply H12 in Hx.
              eapply atomic_rqDown_inits_outs_disj
                with (cidx0:= obj_idx cobj) (rqDown0:= (rqDown, rqdm))
                     (hst:= nhst ++ ruhst); eauto.
              eapply steps_append; eauto.
            }
            { eapply lastOIdxOf_Some_oindsOf_In; eauto.
              rewrite lastOIdxOf_app in H4; [|intro Hx; subst; inv H13].
              assumption.
            }
          }
          repeat ssplit; [reflexivity| |assumption].
          right; exists roidx, [rqUp], ruins, ruouts.
          repeat ssplit; try assumption.
          { eapply DisjList_In_2; eauto. }
          { right; eauto. }
    Qed.

    Definition RqDownP (st: State) :=
      Forall (InMPI st.(st_msgs)) rqDowns.

    Lemma rqDown_lpush_rpush_messages_disj:
      forall rinits rins rhst routs reouts
             linits lins lhst louts leouts,
        DisjList rqDowns rinits ->
        Atomic rinits rins rhst routs reouts ->
        DisjList (oindsOf rhst) (subtreeIndsOf dtr cidx) ->
        DisjList rqDowns linits ->
        Atomic linits lins lhst louts leouts ->
        SubList (oindsOf lhst) (subtreeIndsOf dtr cidx) ->
        forall st1,
          Reachable (steps step_m) sys st1 ->
          RqDownP st1 ->
          forall st2,
            steps step_m sys st1 (lhst ++ rhst) st2 ->
            DisjList reouts linits.
    Proof.
      destruct Hrrs as [? [? ?]]; intros.
      apply (DisjList_false_spec (id_dec msg_dec)).
      intros [midx msg] ? ?.
      unfold RqDownP in H9.
      destruct Hrqd as [cobj [[rqDown rqdm] ?]]; dest; subst.
      inv H9; clear H19.
      simpl in *.

      replace midx with rqDown in *.
      - eapply steps_split in H10; [|reflexivity].
        destruct H10 as [sti [? ?]].
        eapply atomic_rqDown_no_out
          with (cobj0:= cobj) (pobj0:= pobj) (rqDown0:= (rqDown, rqdm))
               (dmsg:= (rqDown, msg)) (st3:= st1) (outs:= routs); eauto.
        + eapply DisjList_In_2; [eassumption|].
          left; reflexivity.
        + eapply atomic_eouts_in; eauto.
      - eapply steps_split in H10; [|reflexivity].
        destruct H10 as [sti [? ?]].
        eapply atomic_ext_outs_in_history in H3; eauto.
        rewrite Forall_forall in H3; specialize (H3 _ H11).
        destruct H3 as [ofrom [? ?]].
        eapply atomic_inits_in_history with (s1:= sti) in H6; eauto.
        rewrite Forall_forall in H6; specialize (H6 _ H12).
        destruct H6 as [oto [? ?]].
        destruct H3 as [|[|]], H6 as [|[|]];
          try (dest; exfalso; solve_midx_false; fail).
        + exfalso; simpl in *.
          destruct H6 as [cidx [? ?]].
          disc_rule_conds.
          eapply DisjList_In_2 in H13; [|eassumption].
          apply H7 in H17.
          elim H13.
          eapply inside_child_in; try apply Hrrs; eauto.
        + exfalso; simpl in *.
          destruct H6 as [cidx [? ?]].
          disc_rule_conds.
          eapply DisjList_In_2 in H13; [|eassumption].
          apply H7 in H17.
          elim H13.
          eapply inside_child_in; try apply Hrrs; eauto.
        + simpl in *; destruct H3 as [cidx [? ?]].
          disc_rule_conds.
          eapply DisjList_In_2 in H13; [|eassumption].
          apply H7 in H17.
          eapply inside_child_outside_parent_case in H17;
            try apply Hrrs; eauto; subst.
          disc_rule_conds.
    Qed.

    Hypothesis (Hoinvs: InvReachable sys step_m (liftObjInvs oinvs)).

    Lemma rqDown_lpush_rpush_unit_reducible:
      forall rinits rins rhst routs reouts
             linits lins lhst louts leouts,
        Atomic rinits rins rhst routs reouts ->
        DisjList (oindsOf rhst) (subtreeIndsOf dtr cidx) ->
        Atomic linits lins lhst louts leouts ->
        SubList (oindsOf lhst) (subtreeIndsOf dtr cidx) ->
        DisjList reouts linits ->
        Reducible sys (lhst ++ rhst) (rhst ++ lhst).
    Proof.
      intros.
      eapply rqrs_reducible; try eassumption.
      eapply DisjList_comm, DisjList_SubList; [eassumption|].
      apply DisjList_comm; assumption.
    Qed.

    Lemma rqDown_lpush_unit_reducible:
      forall pinits pins phst pouts peouts
             inits ins hst outs eouts loidx,
        PInitializing sys RqDownP phst ->
        Atomic pinits pins phst pouts peouts ->
        SubList rqDowns peouts ->
        Atomic inits ins hst outs eouts ->
        lastOIdxOf hst = Some loidx ->
        In loidx (subtreeIndsOf dtr cidx) ->
        DisjList peouts inits ->
        Reducible sys (hst ++ phst) (phst ++ hst).
    Proof.
      intros; red; intros.
      eapply steps_split in H6; [|reflexivity].
      destruct H6 as [sti [? ?]].
      eapply rqDown_lpush_rpush_unit_reducible; try eassumption.
      - eapply rqDown_oinds; try eassumption.
      - eapply rqDown_olast_inside_tree.
        + eapply DisjList_SubList; [|eassumption].
          eassumption.
        + eassumption.
        + eapply reachable_steps; [eassumption|].
          eassumption.
        + eapply H; eassumption.
        + eassumption.
        + eassumption.
        + eassumption.
      - eapply steps_append; eauto.
    Qed.

    Lemma rqDown_rpush_unit_reducible:
      forall inits ins hst outs eouts loidx ridx routs,
        Atomic inits ins hst outs eouts ->
        lastOIdxOf hst = Some loidx ->
        ~ In loidx (subtreeIndsOf dtr cidx) ->
        DisjList rqDowns inits ->
        ReducibleP sys RqDownP (RlblInt cidx ridx rqDowns routs :: hst)
                   (hst ++ [RlblInt cidx ridx rqDowns routs]).
    Proof.
      intros; red; intros.
      inv_steps.
      pose proof (rqDown_olast_outside_tree H2 H Hr Hp H7 H0 H1).
      destruct H3 as [ruhst [nhst ?]]; dest; subst.
      eapply steps_split in H7; [|reflexivity].
      destruct H7 as [sti [? ?]].

      destruct H4; subst.
      - rewrite app_nil_r in *; inv H3.
        eapply rqDown_lpush_rpush_unit_reducible; try eassumption.
        + constructor.
        + simpl; apply SubList_cons; [|apply SubList_nil].
          destruct Hrqd as [dobj [rqDown rqdm]]; dest; subst.
          apply edgeDownTo_subtreeIndsOf_self_in; [apply Hrrs|].
          congruence.
        + red in Hp.
          destruct Hrqd as [dobj [[rqDown rqdm] ?]]; dest; subst.
          inv Hp; clear H12.
          eapply DisjList_SubList; [eapply atomic_eouts_in; eassumption|].
          apply (DisjList_singleton_2 (id_dec msg_dec)).
          eapply atomic_rqDown_inits_outs_disj; eauto.
          eapply DisjList_In_2; eauto.
          left; reflexivity.
        + simpl; econstructor; eauto.

      - destruct H4 as [roidx [rqUps [ruins [ruouts ?]]]]; dest.
        rewrite <-app_assoc.
        eapply reducible_app_1; try assumption.
        + instantiate (1:= RlblInt cidx ridx rqDowns routs :: ruhst).
          red; intros.
          eapply rqUpHistory_lpush_lbl with (rqUps0:= rqUps); try eassumption.
          * inv_steps.
            eapply rqUp_atomic with (rqUps0:= rqUps); eauto.
            { red in H4; dest; subst; discriminate. }
            { right; eauto. }
            { apply SubList_refl. }
          * destruct Hrrs as [? [? ?]].
            clear -Hrqd H4 H13.
            destruct Hrqd as [dobj [[rqDown rqdm] ?]]; dest; subst.
            destruct H4 as [cidx [[rqUp rqum] ?]]; dest; subst.
            apply idsOf_DisjList; simpl in *.
            solve_midx_disj.
        + destruct H11; subst;
            [simpl in *; inv H6; econstructor; eauto|].
          destruct H11 as [nins [nouts ?]].
          change (nhst ++ RlblInt cidx ridx rqDowns routs :: ruhst)
            with (nhst ++ [RlblInt cidx ridx rqDowns routs] ++ ruhst).
          rewrite app_assoc.
          eapply reducible_app_2; try assumption.
          * instantiate (1:= RlblInt cidx ridx rqDowns routs :: nhst).
            change (RlblInt cidx ridx rqDowns routs :: nhst)
              with ([RlblInt cidx ridx rqDowns routs] ++ nhst).
            eapply rqDown_lpush_rpush_unit_reducible; try eassumption.
            { constructor. }
            { simpl; red; intros; dest_in.
              apply edgeDownTo_subtreeIndsOf_self_in.
              { apply Hrrs. }
              { destruct Hrqd; dest; congruence. }
            }
            { eapply DisjList_SubList.
              { eapply atomic_eouts_in, H. }
              { apply DisjList_comm.
                red in Hp.
                destruct Hrqd as [dobj [[rqDown rqdm] ?]]; dest; subst.
                inv Hp; clear H18.
                apply (DisjList_singleton_1 (id_dec msg_dec)).
                eapply atomic_rqDown_inits_outs_disj; eauto.
                { destruct (H2 (rqDown, rqdm)); [|assumption].
                  elim H12; left; reflexivity.
                }
                { eapply steps_append; eassumption. }
              }
            }
          * simpl; econstructor; [|eassumption].
            eapply steps_append; eassumption.
    Qed.

    Lemma rqDown_LRPushable_unit_reducible:
      forall rinits rins rhst routs reouts rloidx
             linits lins lhst louts leouts lloidx,
        Atomic rinits rins rhst routs reouts ->
        DisjList rqDowns rinits ->
        lastOIdxOf rhst = Some rloidx ->
        ~ In rloidx (subtreeIndsOf dtr cidx) ->
        Atomic linits lins lhst louts leouts ->
        DisjList rqDowns linits ->
        lastOIdxOf lhst = Some lloidx ->
        In lloidx (subtreeIndsOf dtr cidx) ->
        ReducibleP sys RqDownP (lhst ++ rhst) (rhst ++ lhst).
    Proof.
      intros; red; intros.
      eapply steps_split in H7; [|reflexivity].
      destruct H7 as [sti [? ?]].
      eapply rqDown_olast_inside_tree in H6;
        [|exact H4
         |eassumption
         |eapply reachable_steps; eassumption
         |eapply atomic_messages_ins_ins;
          try eapply H; try eassumption;
          apply DisjList_comm; assumption
         |eassumption
         |eassumption].
      clear H5.
      eapply rqDown_olast_outside_tree in H2;
        try exact H0; try eassumption.
      clear H1.
      destruct H2 as [ruhst [nhst ?]]; dest; subst.

      destruct H2; subst.
      - rewrite app_nil_r in *.
        eapply rqDown_lpush_rpush_unit_reducible; try eassumption.
        + eapply rqDown_lpush_rpush_messages_disj
            with (rinits:= rinits) (linits:= linits); eauto.
          eapply steps_append; eassumption.
        + eapply steps_append; eassumption.

      - destruct H1 as [roidx [rqUps [ruins [ruouts ?]]]]; dest.
        destruct H11; subst.
        * simpl in *.
          eapply rqUpHistory_lpush_unit_reducible with (rqUps0:= rqUps); eauto.
          { right; eauto. }
          { eapply rqUp_atomic with (rqUps0:= rqUps); eauto; try apply Hiorqs.
            { red in H1; dest; subst; discriminate. }
            { right; auto. }
            { apply SubList_refl. }
          }
          { assert (Reachable (steps step_m) sys sti)
              by (eapply reachable_steps; eassumption).
            clear Hr.
            destruct H1 as [rcidx [rqUp ?]]; dest; subst.
            eapply atomic_inside_tree_inits_disj_rqUps
              with (rqFrom:= rcidx); eauto.
            eapply outside_child_in; try apply Hrrs; eassumption.
          }
          { eapply steps_append; eauto. }
        * destruct H11 as [nins [nouts ?]].
          rewrite <-app_assoc.
          eapply reducible_app_1; try assumption.
          { instantiate (1:= lhst ++ ruhst).
            eapply rqUpHistory_lpush_unit_reducible with (rqUps0:= rqUps); eauto.
            { right; eauto. }
            { eapply steps_split in H7; [|reflexivity].
              destruct H7 as [rsti [? ?]].
              eapply rqUp_atomic with (rqUps0:= rqUps); eauto.
              { red in H1; dest; subst; discriminate. }
              { right; auto. }
              { apply SubList_refl. }
            }
            { assert (Reachable (steps step_m) sys sti)
                by (eapply reachable_steps; eassumption).
              clear Hr.
              destruct H1 as [rcidx [rqUp ?]]; dest; subst.
              eapply atomic_inside_tree_inits_disj_rqUps
                with (rqFrom:= rcidx); eauto.
              eapply outside_child_in; try apply Hrrs; eassumption.
            }
          }
          { rewrite app_assoc.
            eapply reducible_app_2; try assumption.
            { instantiate (1:= lhst ++ nhst).
              eapply rqDown_lpush_rpush_unit_reducible; try eassumption.
              eapply steps_split in H7; [|reflexivity].
              destruct H7 as [rsti [? ?]].
              assert (DisjList rqDowns rqUps).
              { eapply DisjList_comm, DisjList_SubList; [eassumption|].
                apply DisjList_comm.
                unfold RqDownP in Hp.
                destruct Hrqd as [dobj [[rqDown rqdm] ?]]; dest; subst.
                inv Hp.
                apply (DisjList_singleton_1 (id_dec msg_dec)).
                eapply atomic_rqDown_inits_outs_disj; eauto;
                  [|eapply steps_append; eauto].
                specialize (H0 (rqDown, rqdm)); destruct H0; auto.
                elim H0; left; reflexivity.
              }
              eapply rqDown_lpush_rpush_messages_disj
                with (rinits:= rqUps) (linits:= linits) (st1:= rsti); eauto.
              { eapply atomic_messages_ins_ins.
                { eapply H9. }
                { eassumption. }
                { eassumption. }
                { eapply DisjList_comm, H0. }
              }
              { eapply steps_append; eassumption. }
            }
            { rewrite <-app_assoc.
              eapply steps_append; eassumption.
            }
          }
    Qed.

  End OnRqDown.

End RqDownReduction.

Close Scope list.
Close Scope fmap.