From stdpp Require Import finite.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.base_logic.lib Require Import wsat.
From trace_program_logic.prelude Require Import quantifiers iris_extraction finitary classical_instances.
From trace_program_logic.program_logic Require Export
     weakestpre traces.

Set Default Proof Using "Type".
Import uPred.

(* move *)
Lemma step_tp_length {Λ} c c' oζ:
  locale_step (Λ := Λ) c oζ c' → length c.1 ≤ length c'.1.
Proof.
  inversion 1; simplify_eq; last done.
  rewrite !app_length /= !app_length; lia.
Qed.

Lemma valid_exec_length {Λ} ex (tp1 tp2 : list $ expr Λ) σ1 σ2:
  valid_exec ex ->
  trace_starts_in ex (tp1, σ1) ->
  trace_ends_in ex (tp2, σ2) ->
  length tp1 ≤ length tp2.
Proof.
    revert σ1 σ2 tp1 tp2. induction ex as [| ex IH oζ c']; intros σ1 σ2 tp1 tp2.
    - intros ? -> Heq. inversion Heq; simplify_eq; done.
    - intros Hval Hstarts Hends.
      inversion Hval as [A B|A [tp' σ'] C D E Hstep]. simplify_eq.
      etransitivity; first eapply IH =>//.
      pose proof (step_tp_length _ _ _ Hstep) as Hlen. simpl in *.
      rewrite ->Hends in Hlen. simpl in Hlen. lia.
Qed.

Notation wptp_from t0 s t Φs := ([∗ list] tp1_e;Φ ∈ (prefixes_from t0 t);Φs, WP tp1_e.2 @ s; locale_of tp1_e.1 tp1_e.2; ⊤ {{ Φ }})%I.
Notation wptp s t Φs := (wptp_from [] s t Φs).

Notation posts_of t Φs :=
  ([∗ list] vΦ ∈
    (omap (λ x, (λ v, (v, x.2)) <$> to_val x.1)
          (zip_with (λ x y, (x, y)) t Φs)), vΦ.2 vΦ.1)%I.
(* Definition posts_of {Σ} {Λ} (t: list $ expr Λ) (Φs: list (val Λ -> iProp Σ)) := *)
(*   ([∗ list] vΦ ∈ *)
(*     (omap (λ x, (λ v, (v, x.2)) <$> to_val x.1) *)
(*           (zip_with (λ x y, (x, y)) t Φs)), (vΦ.2: val Λ -> iProp Σ) (vΦ.1: val Λ))%I. *)

Definition config_wp `{!irisG Λ AS Σ} : iProp Σ :=
  □ ∀ ex atr c1 σ2 ,
      ⌜valid_exec ex⌝ →
      ⌜trace_ends_in ex c1⌝ →
        ⌜config_step c1.2 σ2⌝ →
        state_interp ex atr ={⊤}[∅]▷=∗
          ∃ δ2 ℓ, ⌜valid_state_evolution ex atr None ℓ (c1.1, σ2) δ2⌝ ∗
                 state_interp (trace_extend ex None (c1.1, σ2)) (trace_extend atr ℓ δ2).

Instance config_wp_persistent `{!irisG Λ AS Σ} : Persistent config_wp.
Proof. apply _. Qed.

Typeclasses Opaque config_wp.

(* the guarded definition of simulation. *)
Definition Gsim_pre Σ {Λ} (AS : AuxState Λ) (s : stuckness)
           (φ : execution_trace Λ → auxiliary_trace AS → Prop)
           (gsim : execution_trace Λ -d> auxiliary_trace AS -d> iPropO Σ) :
  execution_trace Λ -d> auxiliary_trace AS -d> iPropO Σ :=
  (λ ex atr,
   ▷ (⌜valid_system_trace ex atr⌝ ∧
      ⌜φ ex atr⌝ ∧
      ∀ c oζ c' δ,
        ⌜trace_ends_in ex c⌝ →
        ⌜trace_ends_in atr δ⌝ →
        ⌜locale_step c oζ c'⌝ →
        ▷ ▷ (∃ δ' ℓ, ⌜valid_state_evolution ex atr oζ ℓ c' δ'⌝ ∧
                 gsim (trace_extend ex oζ c') (trace_extend atr ℓ δ'))))%I.

Local Instance Gsim_pre_contractive Σ M Λ s φ :
  Contractive (@Gsim_pre Σ M Λ s φ).
Proof.
  rewrite /Gsim_pre=> n wp wp' HGsm ex sm.
  repeat (f_contractive || f_equiv); repeat (apply dist_S; try apply HGsm).
Qed.

Definition Gsim Σ {Λ} (AS : AuxState Λ) (s : stuckness)
           (φ : execution_trace Λ → auxiliary_trace AS → Prop) :
  execution_trace Λ → auxiliary_trace AS → iProp Σ :=
  fixpoint (Gsim_pre Σ AS s φ).

Instance is_except_0_wptp {Σ} Λ AS s φ ex sm:
  IsExcept0 (@Gsim Σ Λ AS s φ ex sm).
Proof.
  rewrite /IsExcept0; iIntros "H".
  rewrite /Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _).
  iMod "H".
  iApply "H"; done.
Qed.

Global Instance Gsim_plain Σ M {Λ} s φ ex sm : Plain (@Gsim Σ M Λ s φ ex sm).
Proof.
  rewrite /Plain.
  iIntros "H".
  iLöb as "IH" forall (ex sm).
  rewrite /Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _).
  rewrite {3 5}/Gsim_pre.
  iApply later_plainly_1; iNext.
  iDestruct "H" as "(#H1 & #H2 & H)".
  iSplit; first (iClear "IH H"; iModIntro; done).
  iSplit; first (iClear "IH H"; iModIntro; done).
  iIntros (c ? ? ? ? ? ?).
  iDestruct ("H" with "[] [] []") as "H"; [done|done|done|].
  do 2 (iApply later_plainly_1; iNext).
  iDestruct "H" as (δ' ℓ) "(#Hst' & H)".
  iExists _, _.
  iSplitR; first by iClear "IH"; iModIntro.
  iApply "IH"; done.
Qed.

Notation locales_equiv_from t0 t0' t1 t1' :=
  (Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e')
           (prefixes_from t0 t1) (prefixes_from t0' t1')).

Section locales_helpers.
  Context {Λ: language}.

  Lemma locales_equiv_from_app (t0 t0' t1 t1' t2 t2': list (expr Λ)):
    locales_equiv_from t0 t0' t1 t1' ->
    locales_equiv_from (t0 ++ t1) (t0' ++ t1') t2 t2' ->
    locales_equiv_from t0 t0' (t1 ++ t2) (t1' ++ t2').
  Proof.
    revert t0 t0' t1 t2 t2'. induction t1' ; intros t0 t0' t1 t2 t2' Hequiv1 Hequiv2.
    - destruct t1; last by apply Forall2_cons_nil_inv in Hequiv1. simpl.
      clear Hequiv1. revert t0 t0' t2 Hequiv2; induction t2'; intros t0 t0' t2 Hequiv2.
      + destruct t2; last by apply Forall2_cons_nil_inv in Hequiv2. constructor.
      + destruct t2; first by inversion Hequiv2.
        rewrite !(right_id_L [] (++)) // in Hequiv2.
    - destruct t1; first by inversion Hequiv1.
      replace ((e :: t1) ++ t2) with (e :: (t1 ++ t2)); last by list_simplifier.
      replace ((a :: t1') ++ t2') with (a :: (t1' ++ t2')); last by list_simplifier.
      simpl. constructor.
      + inversion Hequiv1 =>//.
      + apply IHt1'.
        * inversion Hequiv1 =>//.
        * by list_simplifier.
  Qed.

  Lemma prefixes_from_length {A} (t0 t1: list A):
    length (prefixes_from t0 t1) = length t1.
  Proof. revert t0; induction t1; intros ?; [done|]; rewrite /= IHt1 //. Qed.

  Lemma locales_equiv_from_impl (t0 t0' t1 t1' t2 t2': list (expr Λ)):
    length t2 = length t2' ->
    locales_equiv_from t0 t0' (t1 ++ t2) (t1' ++ t2') ->
    locales_equiv_from (t0 ++ t1) (t0' ++ t1') t2 t2'.
  Proof.
    revert t0 t0' t1 t1' t2. induction t2'; intros t0 t0' t1 t1' t2 Hlen Hequiv.
    - destruct t2 ; simpl in *; done.
    - destruct t2; first done.
      revert e a t0 t0' t1 t2' t2 IHt2' Hlen Hequiv. induction t1'; intros x y t0 t0' t1 t2' t2 IHt2' Hlen Hequiv.
      + destruct t1; first by simpl; constructor; list_simplifier.
        apply Forall2_length in Hequiv. rewrite !prefixes_from_length app_length /= in Hequiv.
        simpl in Hlen. lia.
      + destruct t1.
        { apply Forall2_length in Hequiv. rewrite !prefixes_from_length !app_length /= in Hequiv.
          simpl in Hlen. lia. }
        assert (H: locales_equiv_from (t0 ++ e :: t1) (t0' ++ a :: t1')
                    (x :: t2) (y :: t2')).
        { replace (t0 ++ e :: t1) with ((t0 ++ [e]) ++ t1); last by list_simplifier.
          replace (t0' ++ a :: t1') with ((t0' ++ [a]) ++ t1'); last by list_simplifier.
          apply IHt1' =>//.
          by list_simplifier. }
        simpl; constructor; [inversion H =>// |].
        apply IHt2'; first by simpl in Hlen; lia. done.
  Qed.

  Lemma locales_from_equiv_refl (t0 t0' t: list (expr Λ)):
    locales_equiv t0 t0' ->
    locales_equiv_from t0 t0' t t.
  Proof.
    revert t0 t0'; induction t; intros t0 t0' H; simpl; constructor =>//.
    { apply locale_equiv =>//. }
    apply IHt. apply locales_equiv_from_app =>//. simpl.
    constructor; [ by apply locale_equiv | done].
  Qed.

  Lemma locales_equiv_refl (t: list (expr Λ)):
    locales_equiv t t.
  Proof. apply locales_from_equiv_refl. constructor. Qed.

  Lemma locales_equiv_snoc t0 t0' (e e' : expr Λ) t1 t1':
    locales_equiv t0 t0' ->
    locales_equiv_from t0 t0' t1 t1' ->
    locale_of (t0 ++ t1) e = locale_of (t0' ++ t1') e' ->
    locales_equiv_from t0 t0' (t1 ++ [e]) (t1' ++ [e']).
  Proof.
    intros ???.
    apply locales_equiv_from_app =>//.
    simpl. by constructor.
  Qed.

  Lemma locales_equiv_snoc_same t0 (e e' : expr Λ) t1:
    locale_of (t0 ++ t1) e = locale_of (t0 ++ t1) e' ->
    locales_equiv_from t0 t0 (t1 ++ [e]) (t1 ++ [e']).
  Proof.
    intros ?. apply locales_equiv_snoc =>//; apply locales_from_equiv_refl; apply locales_equiv_refl.
  Qed.

  Lemma locales_equiv_from_middle t0 (e e' : expr Λ) t1 t2:
    locale_of (t0 ++ t1) e = locale_of (t0 ++ t1) e' ->
    locales_equiv_from t0 t0 (t1 ++ e :: t2) (t1 ++ e' :: t2).
  Proof.
    intros ?.
    apply locales_equiv_from_app.
    - apply locales_from_equiv_refl. apply locales_equiv_refl.
    - simpl. constructor; first done.
      apply locales_equiv_from_impl =>//=.
      constructor =>//. apply locales_from_equiv_refl.
      apply locales_equiv_snoc_same. by list_simplifier.
  Qed.

  Lemma locales_equiv_middle (e e' : expr Λ) t1 t2:
    locale_of t1 e = locale_of t1 e' ->
    locales_equiv (t1 ++ e :: t2) (t1 ++ e' :: t2).
  Proof.
    intros ?. apply locales_equiv_from_middle.
    by list_simplifier.
  Qed.

  Lemma locale_step_equiv (c c' : cfg Λ) oζ:
    locale_step c oζ c' ->
    locales_equiv c.1 (take (length c.1) c'.1).
  Proof.
    intros H. inversion H as [? ? e1 ? e2 ? efs t1 t2|]; simplify_eq; simpl.
    - replace (t1 ++ e2 :: t2 ++ efs) with ((t1 ++ e2 :: t2) ++ efs); last by list_simplifier.
      replace (length (t1 ++ e1 :: t2)) with (length (t1 ++ e2 :: t2)); last first.
      { rewrite !app_length //=. }
      rewrite take_app. apply locales_equiv_middle.
      eapply locale_step_preserve =>//.
    - rewrite take_ge =>//. apply locales_equiv_refl.
  Qed.

  Lemma locale_equiv_from_take (t0 t0' t1 t1' : list $ expr Λ) n:
    locales_equiv_from t0 t0' t1 t1' ->
    locales_equiv_from t0 t0' (take n t1) (take n t1').
  Proof.
    revert t0 t0' t1 t1'. induction n as [|n IHn]; intros t0 t0' t1 t1' Hequiv; first constructor.
    destruct t1 as [|e1 t1]; destruct t1' as [|e1' t1']; try by inversion Hequiv.
    simpl. constructor; first by inversion Hequiv.
    apply IHn. by inversion Hequiv.
  Qed.

  Lemma locale_equiv_take (t1 t2 : list $ expr Λ) n:
    locales_equiv t1 t2 ->
    locales_equiv (take n t1) (take n t2).
  Proof. apply locale_equiv_from_take. Qed.

  Lemma locale_equiv_from_transitive (s1 s2 s3 t1 t2 t3 : list $ expr Λ):
    locales_equiv s1 s2 ->
    locales_equiv s2 s3 ->
    locales_equiv_from s1 s2 t1 t2 ->
    locales_equiv_from s2 s3 t2 t3 ->
    locales_equiv_from s1 s3 t1 t3.
  Proof.
    revert s1 s2 s3 t1 t2. induction t3 as [|e3 t3] ; intros s1 s2 s3 t1 t2 Hpref1 Hpref2 Hequiv1 Hequiv2;
      destruct t2 as [|e2 t2]; try by inversion Hequiv2; simplify_eq.
    destruct t1 as [|e1 t1]; try by inversion Hequiv1; simplify_eq.
    simpl; constructor; first by etransitivity; [inversion Hequiv1 | inversion Hequiv2].
    eapply (IHt3 _ (s2 ++ [e2]) _ _ t2).
    - inversion Hequiv1; simplify_eq =>//. apply locales_equiv_snoc =>//. constructor.
    - inversion Hequiv2; simplify_eq =>//. apply locales_equiv_snoc =>//. constructor.
    - inversion Hequiv1 =>//.
    - inversion Hequiv2 => //.
  Qed.

  Lemma locale_equiv_transitive (t1 t2 t3 : list $ expr Λ):
    locales_equiv t1 t2 ->
    locales_equiv t2 t3 ->
    locales_equiv t1 t3.
  Proof. apply locale_equiv_from_transitive; constructor. Qed.

  Lemma locale_valid_exec ex (tp1 tp2 : list $ expr Λ) σ1 σ2:
    valid_exec ex ->
    trace_starts_in ex (tp1, σ1) ->
    trace_ends_in ex (tp2, σ2) ->
    locales_equiv tp1 (take (length tp1) tp2).
  Proof.
    revert σ1 σ2 tp1 tp2. induction ex as [| ex IH oζ c']; intros σ1 σ2 tp1 tp2.
    - intros ? -> Heq. inversion Heq; simplify_eq.
      rewrite take_ge //. apply locales_equiv_refl.
    - intros Hval Hstarts Hends.
      inversion Hval as [A B|A [tp' σ'] C D E Hstep]. simplify_eq.
      eapply locale_equiv_transitive.
      eapply IH =>//.
      pose proof (locale_step_equiv _ _ _ Hstep) as Hequiv.
      rewrite ->Hends in Hequiv. simpl in Hequiv.
      apply (locale_equiv_take _ _ (length tp1)) in Hequiv.
      rewrite take_take in Hequiv.
      assert (length tp1 ≤ length tp').
      { eapply (valid_exec_length ex ) =>//. }
      replace (length tp1 `min` length tp') with (length tp1) in Hequiv; [done|lia].
  Qed.

End locales_helpers.

Section adequacy_helper_lemmas.
  Context `{!irisG Λ AS Σ}.

  Lemma wp_take_step s Φ ex atr tp1 e1 tp2 σ1 e2 σ2 efs ζ:
    valid_exec ex →
    prim_step e1 σ1 e2 σ2 efs →
    trace_ends_in ex (tp1 ++ e1 :: tp2, σ1) →
    locale_of tp1 e1 = ζ ->
    state_interp ex atr -∗
    WP e1 @ s; ζ; ⊤ {{ v, Φ v } } ={⊤}[∅]▷=∗
    ∃ δ' ℓ, ⌜valid_state_evolution ex atr (Some ζ) ℓ (tp1 ++ e2 :: tp2 ++ efs, σ2) δ'⌝ ∗
      state_interp
        (trace_extend ex (Some ζ) (tp1 ++ e2 :: tp2 ++ efs, σ2)) (trace_extend atr ℓ δ') ∗
      WP e2 @ s; ζ; ⊤ {{ v, Φ v } } ∗
                      ([∗ list] i↦ef ∈ efs, WP ef @ s; locale_of (tp1 ++ e1 :: tp2 ++ take i efs) ef; ⊤
                           {{ v, fork_post (locale_of (tp1 ++ e1 :: tp2 ++ take i efs) ef) v }}).
  Proof.
    iIntros (Hex Hstp Hei Hlocale) "HSI Hwp".
    rewrite wp_unfold /wp_pre.
    destruct (to_val e1) eqn:He1.
    { erewrite val_stuck in He1; done. }
    iMod ("Hwp" $! _ _ ectx_emp with "[//] [] [] HSI") as "[Hs Hwp]";
      [by rewrite locale_fill|by rewrite ectx_fill_emp|].
    iMod ("Hwp" with "[]") as "Hwp"; first done.
    iModIntro; iNext.
    rewrite !ectx_fill_emp.
    iMod "Hwp" as (δ' ℓ) "(% & ? & ? & ?)".
    iModIntro; iExists _, _; iFrame; done.
  Qed.

  Lemma wp_not_stuck ex atr K tp1 tp2 σ e s Φ ζ :
    valid_exec ex →
    trace_ends_in ex (tp1 ++ ectx_fill K e :: tp2, σ) →
    locale_of tp1 e = ζ ->
    state_interp ex atr -∗
    WP e @ s; ζ; ⊤ {{ v, Φ v }} ={⊤}=∗
    state_interp ex atr ∗
    WP e @ s; ζ; ⊤ {{ v, Φ v }} ∗
    ⌜s = NotStuck → not_stuck e (trace_last ex).2⌝.
  Proof.
    iIntros (???) "HSI Hwp".
    rewrite /not_stuck assoc.
    iApply fupd_plain_keep_r; iFrame.
    iIntros "[HSI Hwp]".
    rewrite wp_unfold /wp_pre.
    destruct (to_val e) eqn:He.
    - iModIntro; iPureIntro; eauto.
    - iApply fupd_plain_mask.
      iMod ("Hwp" with "[] [] [] HSI") as "[Hs Hwp]"; [done| by erewrite locale_fill|done|].
      erewrite last_eq_trace_ends_in; last done; simpl.
      iModIntro; destruct s; [iDestruct "Hs" as %?|]; iPureIntro; by eauto.
  Qed.

  Lemma wptp_from_same_locales t0' t0 s tp Φs:
    locales_equiv t0 t0' ->
    wptp_from t0' s tp Φs -∗ wptp_from t0 s tp Φs.
  Proof.
    revert Φs t0 t0'. induction tp; intros Φs t0 t0'; iIntros (Hequiv) "H" =>//.
    simpl.
    iDestruct (big_sepL2_cons_inv_l with "H") as (Φ Φs' ->) "[??]".
    rewrite big_sepL2_cons. simpl. erewrite <-locale_equiv =>//. iFrame.
    iApply IHtp =>//. apply locales_equiv_snoc =>//; [constructor|].
    apply locale_equiv =>//.
  Qed.

  Lemma wptp_not_stuck ex atr σ tp t0 t0' trest s Φs :
    Forall2 (λ '(t, e) '(t', e'), locale_of t e = locale_of t' e') (prefixes t0) (prefixes t0') ->
    valid_exec ex →
    trace_ends_in ex (t0 ++ tp ++ trest, σ) →
    state_interp ex atr -∗ wptp_from t0' s tp Φs ={⊤}=∗
    state_interp ex atr ∗ wptp_from t0 s tp Φs ∗
    ⌜∀ e, e ∈ tp → s = NotStuck → not_stuck e (trace_last ex).2⌝.
  Proof.
    iIntros (Hsame Hexvalid Hex) "HSI Ht".
    rewrite assoc.
    rewrite (wptp_from_same_locales t0') =>//.
    iApply fupd_plain_keep_r; iFrame.
    iIntros "[HSI Ht]".
    iIntros (e He).
    apply elem_of_list_split in He as (t1 & t2 & ->).
    rewrite prefixes_from_app.
    iDestruct (big_sepL2_app_inv_l with "Ht") as (Φs1 Φs2') "[-> [Ht1 Het2]]".
    iDestruct (big_sepL2_cons_inv_l with "Het2") as (Φ Φs2) "[-> [He Ht2]]".
    iMod (wp_not_stuck _ _ ectx_emp with "HSI He") as "(_ & _ & ?)";
      [done| rewrite ectx_fill_emp // | |done].
    - replace (t0 ++ (t1 ++ e :: t2) ++ trest) with ((t0 ++ t1) ++ e :: (t2 ++ trest)) in Hex.
      + simpl. done.
      + list_simplifier. done.
    - done.
  Qed.

  Lemma wptp_not_stuck_same ex atr σ tp t0 trest s Φs :
    valid_exec ex →
    trace_ends_in ex (t0 ++ tp ++ trest, σ) →
    state_interp ex atr -∗ wptp_from t0 s tp Φs ={⊤}=∗
    state_interp ex atr ∗ wptp_from t0 s tp Φs ∗
    ⌜∀ e, e ∈ tp → s = NotStuck → not_stuck e (trace_last ex).2⌝.
  Proof.
    iIntros (??) "??". iApply (wptp_not_stuck with "[$] [$]") =>//.
    eapply Forall2_lookup. intros i. destruct (prefixes t0 !! i) as [[??]|]; by constructor.
  Qed.

  Lemma wp_of_val_post e s Φ ζ:
    WP e @ s; ζ; ⊤ {{ v, Φ v }} ={⊤}=∗
    from_option Φ True (to_val e) ∗
    (from_option Φ True (to_val e) -∗ WP e @ s; ζ; ⊤ {{ v, Φ v }}).
  Proof.
    iIntros "Hwp".
    rewrite wp_unfold /wp_pre.
    destruct (to_val e) eqn:He; simpl.
    - iMod "Hwp"; simpl; iFrame; auto.
    - iModIntro.
      iSplit; first by iClear "Hwp".
      iIntros "_"; done.
  Qed.

  Lemma wptp_app s t0 t1 t0t1 Φs1 t2 Φs2 :
    t0t1 = t0 ++ t1 ->
    wptp_from t0 s t1 Φs1 -∗ wptp_from t0t1 s t2 Φs2 -∗ wptp_from t0 s (t1 ++ t2) (Φs1 ++ Φs2).
  Proof.
    iIntros (->) "H1 H2". rewrite prefixes_from_app.
    iApply (big_sepL2_app with "[H1] [H2]"); eauto.
  Qed.

  Lemma wptp_cons_r s e Φ Φs t0 t1:
    WP e @ s; locale_of (t0 ++ t1) e; ⊤ {{v, Φ v}} -∗ wptp_from t0 s t1 Φs
                              -∗ wptp_from t0 s (t1 ++ [e]) (Φs ++ [Φ]).
  Proof.
    iIntros "H1 H2". rewrite !prefixes_from_app.
    iApply (big_sepL2_app with "[H2] [H1]"); eauto.
    rewrite big_sepL2_singleton. done.
  Qed.

  Lemma wptp_cons_l s e Φ t Φs t0:
    WP e @ s; locale_of t0 e; ⊤ {{v, Φ v}} -∗ wptp_from (t0 ++[e]) s t Φs
                              -∗ wptp_from t0 s (e :: t) (Φ :: Φs).
  Proof. iIntros "? ?"; rewrite big_sepL2_cons; iFrame. Qed.

  Lemma wptp_of_val_post t s Φs t0:
    wptp_from t0 s t Φs ={⊤}=∗ posts_of t Φs ∗ (posts_of t Φs -∗ wptp_from t0 s t Φs).
  Proof.
    iIntros "Ht"; simpl.
    iInduction t as [|e t IHt] "IH" forall (Φs t0); simpl.
    { iDestruct (big_sepL2_nil_inv_l with "Ht") as %->; eauto. }
    iDestruct (big_sepL2_cons_inv_l with "Ht") as (Φ Φs') "[-> [He Ht]] /=".
    iMod (wp_of_val_post with "He") as "[Hpost Hback]".
    iMod ("IH" with "Ht") as "[Ht Htback]".
    iModIntro.
    destruct (to_val e); simpl.
    - iFrame.
      iIntros "[Hpost Htpost]".
      iSplitL "Hpost Hback"; [iApply "Hback"|iApply "Htback"]; iFrame.
    - iFrame.
      iIntros "Hefspost".
      iSplitL "Hback"; [iApply "Hback"|iApply "Htback"]; iFrame; done.
  Qed.

  Notation newelems t t' := (drop (length t) t').
  Notation newposts t t' :=
    (map (λ '(tnew, e), fork_post (locale_of tnew e))
        (prefixes_from t (newelems t t'))).

  Lemma newposts_locales_equiv_helper (t0 t0' t1 t1' t : list (expr Λ)):
    length t1 = length t1' ->
    locales_equiv t0 t0' ->
    map (λ '(tnew, e0), fork_post (locale_of tnew e0))
        (prefixes_from t0 (newelems t1 t)) =
    map (λ '(tnew, e0), fork_post (locale_of tnew e0))
        (prefixes_from t0' (newelems t1' t)).
  Proof.
    intros Hlen1 H.
    assert (Hlen2: length t0 = length t0').
    { apply Forall2_length in H. rewrite !prefixes_from_length // in H. }
    revert t0 t0' t1 t1' Hlen1 Hlen2 H. induction t; intros t0 t0' t1 t1' Hlen1 Hlen2 H.
    - rewrite !drop_nil //.
    - destruct t1; destruct t1' =>//.
      + simpl; f_equal; first erewrite locale_equiv=> //.
        specialize (IHt (t0 ++ [a]) (t0' ++ [a]) _ _ Hlen1).
        simpl in IHt. rewrite !drop_0 in IHt. apply IHt.
        * rewrite !app_length. lia.
        * apply locales_equiv_snoc =>//; first constructor.
          list_simplifier. apply locale_equiv =>//.
      + simpl. apply IHt =>//. simpl in Hlen1. lia.
  Qed.

  Lemma forkposts_locales_equiv (t0 t0' t1 t1' : list (expr Λ)):
    locales_equiv_from t0 t0' t1 t1' ->
    map (λ '(tnew, e0), fork_post (locale_of tnew e0))
        (prefixes_from t0 t1) =
    map (λ '(tnew, e0), fork_post (locale_of tnew e0))
        (prefixes_from t0' t1').
  Proof.
    intros H.
    (* assert (Hlen2: length t0 = length t0'). *)
    (* { apply Forall2_length in H. rewrite !prefixes_from_length // in H. } *)
    revert t0 t0' t1' H. induction t1; intros t0 t0' t1' H.
    - destruct t1' =>//. inversion H.
    - destruct t1' =>//; first inversion H.
      inversion H; simplify_eq.
      simpl; f_equal; first by f_equal.
      by apply IHt1.
  Qed.

  Lemma newposts_locales_equiv t0 t0' t:
    locales_equiv t0 t0' ->
    newposts t0 t = newposts t0' t.
  Proof.
    intros H; apply newposts_locales_equiv_helper =>//.
    eapply Forall2_length in H. rewrite !prefixes_from_length // in H.
  Qed.

  Lemma newposts_same_empty t:
    newposts t t = [].
  Proof. rewrite drop_ge //. Qed.

  Lemma new_threads_wptp_from s t efs:
    (([∗ list] i ↦ ef ∈ efs,
      WP ef @ s; locale_of (t ++ take i efs) ef ; ⊤
       {{ v, fork_post (locale_of (t ++ take i efs) ef) v }})
    ⊣⊢
    wptp_from t s efs (newposts t (t ++ efs))).
  Proof.
    (* TODO: factorize the two halves *)
    rewrite big_sepL2_alt; iSplit.
    - iIntros "H". iSplit.
      { rewrite drop_app_alt // map_length !prefixes_from_length //. }
      iInduction efs as [|ef efs] "IH" forall (t); first done.
      rewrite /= !drop_app_alt //=.
      iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame.
      replace (map (λ '(tnew, e), fork_post (locale_of tnew e))
                   (prefixes_from (t ++ [ef]) efs))
        with
          (newposts (t ++[ef]) ((t ++ [ef]) ++ efs)).
      + iApply "IH". iApply (big_sepL_impl with "H").
        iIntros "!>" (k e Hin) "H". by list_simplifier.
      + list_simplifier.
        replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier.
        rewrite drop_app_alt //.
    - iIntros "[_ H]".
      iInduction efs as [|ef efs] "IH" forall (t); first done.
      rewrite /= !drop_app_alt //=.
      iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame.
      replace (map (λ '(tnew, e), fork_post (locale_of tnew e))
                   (prefixes_from (t ++ [ef]) efs))
        with
          (newposts (t ++[ef]) ((t ++ [ef]) ++ efs)).
      + iSpecialize ("IH" with "H"). iApply (big_sepL_impl with "IH").
        iIntros "!>" (k e Hin) "H". by list_simplifier.
      + list_simplifier.
        replace (t ++ ef :: efs) with ((t ++ [ef]) ++ efs); last by list_simplifier.
        rewrite drop_app_alt //.
  Qed.

  Lemma take_step s Φs ex atr c c' oζ:
    valid_exec ex →
    trace_ends_in ex c →
    locale_step c oζ c' →
    config_wp -∗
    state_interp ex atr -∗
    wptp s c.1 Φs  ={⊤}[∅]▷=∗
    ⌜∀ e2, s = NotStuck → e2 ∈ c'.1 → not_stuck e2 c'.2⌝ ∗
    ∃ δ' ℓ, ⌜valid_state_evolution ex atr oζ ℓ c' δ'⌝ ∗
      state_interp (trace_extend ex oζ c') (trace_extend atr ℓ δ') ∗
      posts_of  c'.1 (Φs ++ newposts c.1 c'.1) ∗
      (posts_of c'.1 (Φs ++ newposts c.1 c'.1) -∗
        wptp s  c'.1 (Φs ++ newposts c.1 c'.1)).
  Proof.
    iIntros (Hexvalid Hexe Hstep) "config_wp HSI Hc1".
    inversion Hstep as
        [ρ1 ρ2 e1 σ1 e2 σ2 efs t1 t2 -> -> Hpstep | ρ1 ρ2 σ1 σ2 t -> -> Hcfgstep].
    - rewrite /=.
      (* replace (length (t1 ++ e2 :: t2 ++ efs) - length (t1 ++ e1 :: t2)) with *)
      (*     (length efs); last first. *)
      (* { rewrite !app_length /= !app_length; lia. } *)
      rewrite !prefixes_from_app.
      iDestruct (big_sepL2_app_inv_l with "Hc1") as
          (Φs1 Φs2') "[-> [Ht1 Het2]]".
      iDestruct (big_sepL2_cons_inv_l with "Het2") as (Φ Φs2) "[-> [He Ht2]]".
      iMod (wp_take_step with "HSI He") as "He"; [done|done|done|done|].
      iModIntro; iNext.
      iMod "He" as (δ' ℓ) "(% & HSI & He2 & Hefs) /=".
      (* rewrite -(big_sepL2_replicate_r efs fork_post *)
      (*            (λ _ e Φ, WP e @ s; ⊤ {{v, Φ v}})%I); last reflexivity. *)
      have Heq: forall a b c d, a ++ e1 :: c ++ d = (a ++ e1 :: c) ++ d.
      { intros **. by list_simplifier. }

      iAssert (wptp_from (t1 ++ e2 :: t2) s efs (newposts (t1 ++ e2 :: t2) ((t1 ++ e2 :: t2) ++ efs)))
        with "[Hefs]" as "Hefs".
      { rewrite -new_threads_wptp_from. iApply (big_sepL_impl with "Hefs").
        iIntros "!#" (i e Hin) "Hwp". list_simplifier.
        erewrite locale_equiv; first by iFrame.
        apply locales_equiv_middle. erewrite locale_step_preserve =>//. }
      assert (valid_exec (ex :tr[Some (locale_of t1 e1)]: (t1 ++ e2 :: t2 ++ efs, σ2))).
      { econstructor; eauto. }
      iMod (wptp_not_stuck_same _ _ σ2 _ _ [] with "HSI Hefs") as "[HSI [Hefs %]]"; [done| | ].
      { list_simplifier. done. }
      iMod (wptp_not_stuck_same _ _ σ2 _ _ (e2 :: (t2 ++ efs)) with "HSI Ht1") as "[HSI [Ht1 %]]"; [done|  |].
      {  list_simplifier. done. }
      iMod (wptp_not_stuck _ _ σ2 _ (t1 ++ [e2]) _ efs with "HSI Ht2") as "[HSI [Ht2 %]]"; [| done | |].
      { rewrite !prefixes_from_app. apply Forall2_app.
        - apply locales_equiv_refl.
        - constructor; last constructor. list_simplifier. erewrite <-locale_step_preserve =>//. }
      { list_simplifier. done. }
      iMod (wp_not_stuck _ _ ectx_emp with "HSI He2") as "[HSI [He2 %]]";
        [done|by rewrite ectx_fill_emp|by erewrite <-locale_step_preserve|].

      iDestruct (wptp_app with "Ht2 Hefs") as "Ht2efs".
      { by list_simplifier. }
      erewrite (locale_step_preserve e1 e2) =>//.
      iDestruct (wptp_cons_l with "He2 Ht2efs") as "He2t2efs".
      iDestruct (wptp_app with "Ht1 He2t2efs") as "Hc2"; [by list_simplifier|].
      iMod (wptp_of_val_post with "Hc2") as "[Hc2posts Hc2back]".
      iModIntro; simpl in *.
      iSplit.
      { iPureIntro; set_solver. }
      iExists δ', ℓ.
      iSplit; first by erewrite <-locale_step_preserve.
      rewrite -!app_assoc.
      iFrame.
      list_simplifier.
      erewrite newposts_locales_equiv;
        [iFrame | apply locales_equiv_middle; erewrite <-locale_step_preserve =>//].
      iIntros "H". iSpecialize ("Hc2back" with "H").
      rewrite prefixes_from_app //.
    - rewrite /= /config_wp.
      iMod ("config_wp" with "[] [] [] HSI") as "Hcfg"; [done|done|done|].
      iModIntro; iNext; iMod "Hcfg" as (δ2 ℓ) "[% HSI]".
      assert (valid_exec (ex :tr[None]: ((t, σ1).1, σ2))).
      { econstructor; eauto. }
      iMod (wptp_not_stuck _ _ σ2 _ _ _ [] with "HSI Hc1") as "[HSI [Hc1 %]]";
        [apply locales_equiv_refl|done|by list_simplifier|].
      iMod (wptp_of_val_post with "Hc1") as "[Hc1posts Hc1back]".
      iModIntro.
      iSplit; first by auto.
      iExists δ2, ℓ; iSplit; first done.
      rewrite newposts_same_empty. list_simplifier.
      iFrame.
  Qed.

End adequacy_helper_lemmas.

Theorem wp_strong_adequacy_helper Σ Λ AS `{!invGpreS Σ}
        (s: stuckness) (φ : execution_trace Λ → auxiliary_trace AS → Prop)
        e1 σ1 δ:
  (∀ `{Hinv : !invGS Σ},
    ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (trace_inv : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (Φ : val Λ → iProp Σ)
         (fork_post : locale Λ → val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗
       stateI (trace_singleton ([e1], σ1)) (trace_singleton δ) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗
       (∀ (ex : execution_trace Λ) (atr : auxiliary_trace AS)
            δ' c,
         ⌜valid_system_trace ex atr⌝ -∗
         ⌜trace_starts_in ex ([e1], σ1)⌝ -∗
         ⌜trace_starts_in atr δ⌝ -∗
         ⌜trace_ends_in ex c⌝ -∗
         ⌜trace_ends_in atr δ'⌝ -∗
         ⌜∀ ex' atr' oζ ℓ,
             trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
          φ ex' atr' ∧
          valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)⌝ -∗
         ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗
         stateI ex atr -∗
         (* posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop 1 c.1)))) -∗ *)
         posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗
         □ (stateI ex atr ∗
             (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
            ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗
         ((∀ ex' atr' oζ ℓ,
              ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
          ={⊤, ∅}=∗ ⌜φ ex atr⌝))) →
  ⊢ Gsim Σ AS s φ (trace_singleton ([e1], σ1)) (trace_singleton δ).
Proof.
  intros Hwp.
  iMod wsat_alloc as (Hinv) "[Hw HE]".
  iPoseProof Hwp as "Hwp".
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("Hwp" with "[$Hw $HE]") as ">[Hw [HE Hwp']]".
  iClear "Hwp".
  iDestruct "Hwp'" as (stateI trace_inv Φ fork_post) "(#config_wp & HSI & Hwp & Hstep)".
  clear Hwp.
  set (IrisG Λ AS Σ Hinv stateI fork_post).
  iAssert (∃ ex atr c1 δ1,
              ⌜trace_singleton ([e1], σ1) = ex⌝ ∗
              ⌜trace_singleton δ = atr⌝ ∗
              ⌜([e1], σ1) = c1⌝ ∗
              ⌜δ = δ1⌝ ∗
              ⌜length c1.1 ≥ 1⌝ ∗
              stateI ex atr ∗
              (∀ ex' atr' oζ ℓ,
                  ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr') ∗
              wptp s c1.1 (Φ :: map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop 1 c1.1))))%I
    with "[HSI Hwp]" as "Hex".
  { iExists (trace_singleton ([e1], σ1)), (trace_singleton δ), ([e1], σ1), δ; simpl.
    iFrame.
    repeat (iSplit; first by auto).
    iIntros (???? ?%not_trace_contract_singleton); done. }
  iDestruct "Hex" as (ex atr c1 δ1 Hexsing Hatrsing Hc1 Hδ1 Hlen) "(HSI & HTI & Htp)".
  assert
    (valid_system_trace ex atr ∧
     trace_starts_in ex ([e1], σ1) ∧
     trace_ends_in ex c1 ∧
     trace_starts_in atr δ ∧
     trace_ends_in atr δ1 ∧
     (∀ ex' atr' oζ ℓ,
         trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
         φ ex' atr' ∧
         valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)))
    as Hextras.
  { rewrite -Hexsing -Hatrsing -Hc1 -Hδ1.
    split; first apply valid_system_trace_singletons.
    repeat (split; first done).
    intros ? ? ? ? ? ?%not_trace_contract_singleton; done. }
  clear Hc1 Hδ1.
  rewrite Hexsing Hatrsing; clear Hexsing Hatrsing.
  iLöb as "IH" forall (ex atr c1 δ1 Hextras Hlen) "HSI HTI Htp".
  destruct Hextras as (Hexatr & Hex & Hc1 & Hatr & Hδ1 & Hφ).
  rewrite {2}/Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _).
  iSplit; first done.
  destruct c1 as [tp σ1'].
  assert (valid_exec ex).
  { by eapply valid_system_trace_valid_exec_trace. }
  iPoseProof (wptp_not_stuck _ _ _ _ _ _ [] with "[$HSI] Htp") as "Htp";
    [apply locales_equiv_refl|done|by list_simplifier|].
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("Htp" with "[$Hw $HE]") as ">(Hw & HE & HSI & Htp & %Hnstk)".
  rewrite (last_eq_trace_ends_in _ (tp, σ1')) in Hnstk; last done.
  iPoseProof (wptp_of_val_post with "Htp") as "Htp".
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("Htp" with "[$Hw $HE]") as ">(Hw & HE & Hpost & Hback)".
  iAssert (▷ ⌜φ ex atr⌝)%I as "#Hφ".
  { iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI Hpost") as "[_ Hφ]"; auto.
    iMod ("Hφ" with "HTI [$Hw $HE]") as ">(Hw & HE & %)"; auto. }
  iAssert (□ (stateI ex atr -∗
               (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ →
                            trace_inv ex' atr') -∗
               wsat ∗ ownE ⊤ ==∗
               ◇ (wsat ∗ ownE ⊤ ∗ stateI ex atr ∗ trace_inv ex atr)))%I as "#HTIextend".
  { iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI Hpost") as "[#Hext _]"; auto.
    iModIntro.
    iIntros "HSI HTI [Hw HE]".
    iApply ("Hext" with "[$HSI $HTI] [$Hw $HE]"). }
  iMod ("HTIextend" with "HSI HTI [$Hw $HE]") as ">(Hw & HE & HSI & HTI)".
  iDestruct ("Hback" with "Hpost") as "Htp".
  iNext; iSplit; first done.
  iDestruct "Hφ" as %Hφ'.
  iIntros (c oζ c' δ' Hc Hδ' Hstep).
  pose proof (trace_ends_in_inj ex c (tp, σ1') Hc Hc1); simplify_eq.
  pose proof (trace_ends_in_inj atr δ1 δ' Hδ1 Hδ'); simplify_eq.
  iPoseProof (take_step with "config_wp HSI Htp") as "Hstp"; [done|done|done|].
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("Hstp" with "[$Hw $HE]") as ">(Hw & HE & Hstp)".
  iNext.
  iMod ("Hstp" with "[$Hw $HE]") as ">(Hw & HE & % & H)".
  iDestruct "H" as (δ'' ℓ) "(% & HSI & Hpost & Hback)"; simpl in *.

  iSpecialize ("Hback" with "Hpost").

  assert (Hlocales: map (λ '(tnew, e), weakestpre.fork_post (locale_of tnew e))
                    (prefixes_from [e1] (drop 1 tp)) ++
                  map (λ '(tnew, e), weakestpre.fork_post (locale_of tnew e))
                  (prefixes_from tp (drop (length tp) c'.1))
         = map (λ '(tnew, e), weakestpre.fork_post (locale_of tnew e))
                    (prefixes_from [e1] (drop 1 c'.1)) ).
  { pose proof (locale_valid_exec _ _ _ _ _ H Hex Hc) as Hequivex.

    destruct c'.1 as [|e3 tp3_rest] eqn:Heq.
    { exfalso. pose proof (step_tp_length _ _ _ Hstep). rewrite ->Heq in *. simpl in *. lia. }
    destruct tp as [|e2 tp2_rest] eqn:Heq'.
    { simpl in Hlen; lia. }

    change fork_post with weakestpre.fork_post.
    assert (locale_of [] e1 = locale_of [] e2); first by inversion Hequivex.

    change 1 with (length [e1]).
    rewrite !(newposts_locales_equiv [e1] [e2]); [| by constructor =>// | by constructor =>//].
    rewrite ![drop _ _]/=.
    rewrite drop_0.
    assert (Hequiv: locales_equiv (e2 :: tp2_rest) (take (length (e2 :: tp2_rest)) (e3 :: tp3_rest))).
    { pose proof (locale_step_equiv _ _ _ Hstep) as Hequiv.
      rewrite Heq // in Hequiv. }
    assert (Hequiv_from: locales_equiv_from [e2] [e3] tp2_rest (take (length tp2_rest) tp3_rest)).
    { change [e2] with ([] ++ [e2]).
      change [e3] with ([] ++ [e3]).
      change (e2 :: tp2_rest) with ([e2] ++ tp2_rest) in Hequiv.
      rewrite [take _ _]/= in Hequiv.
      change (e3 :: take (length tp2_rest) tp3_rest) with ([e3] ++ take (length tp2_rest) tp3_rest) in Hequiv.
      assert (length tp2_rest = length (take (length tp2_rest) tp3_rest)) as Hlen'.
      { rewrite take_length. pose proof (step_tp_length _ _ _ Hstep) as Hdec.
        rewrite Heq /= in Hdec. lia. }
      apply (locales_equiv_from_impl _ _ _ _ _ _ Hlen' Hequiv) =>//. }
    erewrite forkposts_locales_equiv; last done.
    assert (Hequiv_from': forall t, locales_equiv_from (e2 :: tp2_rest) (e3 :: take (length tp2_rest) tp3_rest) t t).
    { intros t. by apply locales_from_equiv_refl. }
    erewrite (forkposts_locales_equiv (e2 :: tp2_rest)); last first.
    { eauto using Hequiv_from'. }
    assert (Hequiv_from'': forall t, locales_equiv_from [e2] [e3] t t).
    { intros t. apply locales_from_equiv_refl. constructor =>//. by inversion Hequiv. }
    erewrite (forkposts_locales_equiv [e2]); last by eauto.

    rewrite -map_app -prefixes_from_app take_drop.
    rewrite [drop _ _]/= drop_0 //. }

  iAssert (▷ ⌜φ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ'')⌝)%I as "#Hextend'".
  { iDestruct ("Hstep" with "[] [] [] [] [] [] [] HSI") as "H"; [iPureIntro..|].
    - eapply valid_system_trace_extend; eauto.
    - eapply trace_extend_starts_in; eauto.
    - eapply trace_extend_starts_in; eauto.
    - eapply trace_extend_ends_in; eauto.
    - eapply trace_extend_ends_in; eauto.
    - by intros ? ? ? ? [-> ->]%trace_contract_of_extend [-> ->]%trace_contract_of_extend.
    - done.
    - rewrite Hlocales.
      iPoseProof (wptp_of_val_post with "Hback") as "Hback".
      rewrite uPred_fupd_eq /uPred_fupd_def.
      iMod ("Hback" with "[$Hw $HE]") as ">(Hw & HE & Hpost & Hwptp)".
      iDestruct ("H" with "Hpost") as "[? Hφ]".
      iMod ("Hφ" with "[HTI] [$Hw $HE]") as ">(Hw & HE & %)"; last done.
      iIntros (? ? ? ? [-> ->]%trace_contract_of_extend
                 [-> ->]%trace_contract_of_extend); done. }
  iNext.
  iExists _, _; iSplit; first done.
  iApply ("IH" with "[] [] Hw HE Hstep HSI [HTI]");
    [| | |iFrame].
  - iPureIntro; split_and!.
    + eapply valid_system_trace_extend; eauto.
    + eapply trace_extend_starts_in; eauto.
    + eapply trace_extend_ends_in; eauto.
    + eapply trace_extend_starts_in; eauto.
    + eapply trace_extend_ends_in; eauto.
    + by intros ???? [-> ->]%trace_contract_of_extend
                [-> ->]%trace_contract_of_extend.
  - iPureIntro. pose proof (step_tp_length _ _ _ Hstep). simpl in *. lia.
  - iIntros (???? [-> ->]%trace_contract_of_extend
                  [-> ->]%trace_contract_of_extend); done.
  - change fork_post with weakestpre.fork_post.
    rewrite Hlocales //.
Qed.

Definition valid_state_evolution_finitary {Λ} (AS : AuxState Λ) φ :=
  ∀ ex atr c' oζ, smaller_card
    (sig (λ '(δ', ℓ), @valid_state_evolution Λ AS ex atr oζ ℓ c' δ' ∧ φ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ'))) nat.

Section finitary_lemma.
  Lemma valid_state_evolution_finitary_impl {Λ}  (AS : AuxState Λ)
        `{EqDecision (mlabel AS), EqDecision AS} (φ φ' : _ -> _ -> Prop):
    (∀ ex aux, φ ex aux -> φ' ex aux) ->
    valid_state_evolution_finitary AS φ' ->
    valid_state_evolution_finitary AS φ.
  Proof.
    intros Himpl Hφ' ex aux c' oζ.

    assert (forall φ x, ProofIrrel (match x return Prop with (δ', ℓ) =>
                                                     valid_state_evolution ex aux
                                                                                oζ ℓ c' δ'
                                                          ∧ φ (ex :tr[ oζ ]: c')
                                                              (aux :tr[ ℓ ]: δ')
                             end)).
    { intros ?[??]. apply make_proof_irrel. }

    apply finite_smaller_card_nat.
    specialize (Hφ' ex aux c' oζ). apply smaller_card_nat_finite in Hφ'.
    eapply (in_list_finite (map proj1_sig (@enum _ _ Hφ'))).
    intros [δ' ℓ] [??]. apply elem_of_list_fmap.
    assert ((λ '(δ', ℓ), valid_state_evolution ex aux oζ ℓ c' δ'
                         ∧ φ' (ex :tr[ oζ ]: c') (aux :tr[ ℓ ]: δ')) (δ', ℓ)).
    { eauto. }
    exists ((δ', ℓ) ↾ ltac:(eauto)). split =>//.
    apply elem_of_enum.
  Qed.
End finitary_lemma.

(* Notations on executions
 * |-----------ex'-------|
 * |-----------ex-----------|
 * x1 ----------------- x2 x3
 *)
Theorem wp_strong_adequacy_with_trace_inv Λ AS Σ `{!invGpreS Σ}
        (s: stuckness)
        (φ : execution_trace Λ → auxiliary_trace AS → Prop)
        e1 σ1 δ1 :
  valid_state_evolution_finitary AS φ →
  (∀ `{Hinv : !invGS Σ},
    ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (trace_inv : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (Φ : val Λ → iProp Σ)
         (fork_post : locale Λ → val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗
       stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗
       (∀ (ex : execution_trace Λ) (atr : auxiliary_trace AS)
            δ' c,
         ⌜valid_system_trace ex atr⌝ -∗
         ⌜trace_starts_in ex ([e1], σ1)⌝ -∗
         ⌜trace_starts_in atr δ1⌝ -∗
         ⌜trace_ends_in ex c⌝ -∗
         ⌜trace_ends_in atr δ'⌝ -∗
         ⌜∀ ex' atr' oζ ℓ,
             trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
          φ ex' atr' ∧
          valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)⌝ -∗
         ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗
         stateI ex atr -∗
         (* posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop 1 c.1)))) -∗ *)
         posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗
         □ (stateI ex atr ∗
             (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
            ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗
         ((∀ ex' atr' oζ ℓ,
              ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
          ={⊤, ∅}=∗ ⌜φ ex atr⌝))) →
  continued_simulation φ (trace_singleton ([e1], σ1)) (trace_singleton δ1).
Proof.
  intros Hsc Hwptp%wp_strong_adequacy_helper; last done.
  exists (λ exatr, ⊢ Gsim Σ AS s φ exatr.1 exatr.2); split; first done.
  clear Hwptp.
  intros [ex atr] Hgsim; simpl.
  revert Hgsim.
  rewrite {1}/Gsim (fixpoint_unfold (Gsim_pre _ _ _ _) _ _); intros Hgsim;
    simpl in *.
  revert Hgsim; rewrite extract_later; intros Hgsim.
  apply extract_and in Hgsim as [Hvlt Hgsim].
  revert Hvlt; rewrite extract_pure; intros Hvlt.
  split; first done.
  apply extract_and in Hgsim as [Hφ Hgsim].
  revert Hφ; rewrite extract_pure; intros Hφ.
  split; first done.
  intros c c' δ' oζ Hsmends Hsimends Hstep.
  revert Hgsim; rewrite extract_forall; intros Hgsim.
  specialize (Hgsim c).
  revert Hgsim; rewrite extract_forall; intros Hgsim.
  specialize (Hgsim oζ).
  revert Hgsim; rewrite extract_forall; intros Hgsim.
  specialize (Hgsim c').
  revert Hgsim; rewrite extract_forall; intros Hgsim.
  specialize (Hgsim δ').
  apply (extract_impl ⌜_⌝) in Hgsim; last by apply extract_pure.
  apply (extract_impl ⌜_⌝) in Hgsim; last by apply extract_pure.
  apply (extract_impl ⌜_⌝) in Hgsim; last by apply extract_pure.
  revert Hgsim; rewrite !extract_later; intros Hgsim.

  simpl in *.

  assert (⊢ ▷ ∃ (δ': AS) ℓ,
               (⌜valid_state_evolution ex atr oζ ℓ c' δ' ∧ φ (ex :tr[oζ]: c') (atr :tr[ℓ]: δ')⌝) ∧
               fixpoint (Gsim_pre Σ AS s φ) (ex :tr[oζ]: c') (atr :tr[ℓ]: δ')).
  { iStartProof. iDestruct Hgsim as (δ'' ℓ) "[Hval Hfix]". iExists δ'', ℓ.
    iSplit; last done. iSplit; first done.
    rewrite (fixpoint_unfold (Gsim_pre _ _ _ _) _ _) /Gsim_pre.
    iNext. by iDestruct "Hfix" as "[_ [? _]]". }

  rewrite -> extract_later in H.
  apply extract_exists_alt2 in H as (δ'' & ℓ & H); last done.

  exists δ'', ℓ.
  revert H.
  rewrite !extract_and.
  intros [? ?]; done.
Qed.

(* Notations on executions
 * |-----------ex'-------|
 * |-----------ex-----------|
 * x1 ----------------- x2 x3
 *)
Theorem wp_strong_adequacy Λ AS Σ `{!invGpreS Σ}
        (s: stuckness)
        (φ : execution_trace Λ → auxiliary_trace AS → Prop)
        e1 σ1 δ1 :
  valid_state_evolution_finitary AS φ →
  (∀ `{Hinv : !invGS Σ},
    ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (Φ : val Λ → iProp Σ)
         (fork_post : locale Λ → val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗
       stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗
       (∀ (ex : execution_trace Λ) (atr : auxiliary_trace AS)
            δ' c,
         ⌜valid_system_trace ex atr⌝ -∗
         ⌜trace_starts_in ex ([e1], σ1)⌝ -∗
         ⌜trace_starts_in atr δ1⌝ -∗
         ⌜trace_ends_in ex c⌝ -∗
         ⌜trace_ends_in atr δ'⌝ -∗
         ⌜∀ ex' atr' oζ ℓ,
             trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
          φ ex' atr' ∧
          valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)⌝ -∗
         ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗
         stateI ex atr -∗
         posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗
         |={⊤, ∅}=> ⌜φ ex atr⌝)) ->
  continued_simulation φ (trace_singleton ([e1], σ1)) (trace_singleton δ1).
Proof.
  intros Hsc Hwptp.
  eapply wp_strong_adequacy_with_trace_inv; [done|done|].
  iIntros (Hinv) "".
  iMod (Hwptp Hinv) as (stateI Φ fork_post) "(Hwpcfg & HSI & Hwp & Hstep)".
  iModIntro.
  iExists stateI, (λ _ _, True)%I, Φ, fork_post; iFrame "Hwpcfg HSI Hwp".
  iIntros (ex atr δ' c ? ? ? ? ? ? ?) "HSI Hposts".
  iSplit; last first.
  { iIntros "?". iApply ("Hstep" with "[] [] [] [] [] [] [] HSI"); eauto. }
  iModIntro; iIntros "[$ ?]"; done.
Qed.

(** Since the full adequacy statement is quite a mouthful, we prove some more
intuitive and simpler corollaries. These lemmas are morover stated in terms of
[rtc erased_step] so one does not have to provide the trace. *)
Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ)
    (φ : val Λ → state Λ → Prop) : Prop := {
  adequate_result ex t2 σ2 v2 :
    valid_exec ex →
   trace_starts_in ex ([e1], σ1) →
   trace_ends_in ex (of_val v2 :: t2, σ2) →
   φ v2 σ2;
  adequate_not_stuck ex t2 σ2 e2 :
   s = NotStuck →
   valid_exec ex →
   trace_starts_in ex ([e1], σ1) →
   trace_ends_in ex (t2, σ2) →
   e2 ∈ t2 → not_stuck e2 σ2
}.

Lemma adequate_alt {Λ} s e1 σ1 (φ : val Λ → state Λ → Prop) :
  adequate s e1 σ1 φ ↔ ∀ ex t2 σ2,
      valid_exec ex →
      trace_starts_in ex ([e1], σ1) →
      trace_ends_in ex (t2, σ2) →
      (∀ v2 t2', t2 = of_val v2 :: t2' → φ v2 σ2) ∧
      (∀ e2, s = NotStuck → e2 ∈ t2 → not_stuck e2 σ2).
Proof.
  split.
  - intros []; naive_solver.
  - constructor; naive_solver.
Qed.

Theorem adequate_tp_safe {Λ} (e1 : expr Λ) ex t2 σ1 σ2 φ :
  adequate NotStuck e1 σ1 φ →
  valid_exec ex →
  trace_starts_in ex ([e1], σ1) →
  trace_ends_in ex (t2, σ2) →
  Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, step (t2, σ2) (t3, σ3).
Proof.
  intros Had ? ? ?.
  destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|].
  apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
  destruct (adequate_not_stuck NotStuck e1 σ1 φ Had ex t2 σ2 e2)
    as [?|(e3&σ3&efs&?)];
    rewrite ?eq_None_not_Some; auto.
  { exfalso. eauto. }
  destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto.
  right; exists (t2' ++ e3 :: t2'' ++ efs), σ3; econstructor; eauto.
Qed.

Local Definition wp_adequacy_relation Λ AS s (φ : val Λ → Prop)
           (ex : execution_trace Λ) (atr : @auxiliary_trace Λ AS) : Prop :=
  ∀ c, trace_ends_in ex c →
       (∀ v2 t2', c.1 = of_val v2 :: t2' → φ v2) ∧
       (∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2).

Local Lemma wp_adequacy_relation_adequacy {Λ AS} s e σ δ φ (ξ : _ -> _ -> Prop):
  (forall ex aux, ξ ex aux -> wp_adequacy_relation Λ AS s φ ex aux) ->
  continued_simulation
    ξ
    (trace_singleton ([e], σ))
    (trace_singleton δ) →
  adequate s e σ (λ v _, φ v).
Proof.
  intros Himpl Hsm; apply adequate_alt.
  intros ex t2 σ2 Hex Hexstr Hexend.
  eapply simulation_does_continue in Hex as [atr [? Hatr]]; eauto.
  rewrite -> continued_simulation_unfold in Hatr.
  destruct Hatr as (Hvlt & Hψ & Hatr).
  apply Himpl in Hψ.
  apply (Hψ (t2, σ2)); done.
Qed.

Corollary adequacy_xi Λ (AS : AuxState Λ) Σ `{!invGpreS Σ} `{EqDecision (mlabel AS), EqDecision AS}
        (s: stuckness)
        (φ : execution_trace Λ → auxiliary_trace AS → Prop)
        e1 σ1 δ1 :
  valid_state_evolution_finitary AS φ →
  (∀ `{Hinv : !invGS Σ},
    ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (trace_inv : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (Φ : val Λ → iProp Σ)
         (fork_post : locale Λ → val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗
       stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗
       (∀ (ex : execution_trace Λ) (atr : auxiliary_trace AS)
            δ' c,
         ⌜valid_system_trace ex atr⌝ -∗
         ⌜trace_starts_in ex ([e1], σ1)⌝ -∗
         ⌜trace_starts_in atr δ1⌝ -∗
         ⌜trace_ends_in ex c⌝ -∗
         ⌜trace_ends_in atr δ'⌝ -∗
         ⌜∀ ex' atr' oζ ℓ,
             trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
          φ ex' atr' ∧
          valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)⌝ -∗
         ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗
         stateI ex atr -∗
         (* posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop 1 c.1)))) -∗ *)
         posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗
         □ (stateI ex atr ∗
             (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
            ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗
         ((∀ ex' atr' oζ ℓ,
              ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
          ={⊤, ∅}=∗ ⌜φ ex atr⌝))) →
  adequate s e1 σ1 (λ v _, True).
Proof.
  pose (ξ := λ ex aux, φ ex aux ∧ wp_adequacy_relation Λ AS s (λ _, True) ex aux).
  intros ? Hwp; apply (wp_adequacy_relation_adequacy (AS := AS) _ _ _ δ1 _ ξ).
  { unfold ξ. by intros ??[??]. }
  apply (wp_strong_adequacy_with_trace_inv Λ AS Σ s).
  { apply (valid_state_evolution_finitary_impl _ ξ φ) =>//. by intros ??[??]. }
  iIntros (?) "".
  iMod Hwp as (stateI Φ post fork_post) "(config_wp & HSI & Hwp & H)".
  iModIntro; iExists _, _, _, _. iFrame "config_wp HSI Hwp".
  iIntros (ex atr δ' c Hvlt Hexs Hatrs Hexe Hatre Hψ Hnst) "HSI Hposts".
  iSpecialize ("H" with "[//] [//] [//] [//] [//] [] [//]").
  - iPureIntro. intros ??????.
    unfold ξ in Hψ. specialize (Hψ _ _ _ _ ltac:(done) ltac:(done)) as [[??]?].
    by split.
  - iDestruct ("H" with "HSI Hposts") as "[? H]". iSplit =>//.
    iIntros "H1". iMod ("H" with "H1"). iModIntro. iSplit=>//.
    iIntros (c' Hc').
    assert (c' = c) as -> by by eapply trace_ends_in_inj.
    iSplit; last done. by iIntros (v2 t2 ?).
Qed.

Corollary sim_and_adequacy_xi Λ (AS : AuxState Λ) Σ `{!invGpreS Σ} `{EqDecision (mlabel AS), EqDecision AS}
        (s: stuckness)
        (φ : execution_trace Λ → auxiliary_trace AS → Prop)
        e1 σ1 δ1 :
  valid_state_evolution_finitary AS φ →
  (∀ `{Hinv : !invGS Σ},
    ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (trace_inv : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (Φ : val Λ → iProp Σ)
         (fork_post : locale Λ → val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗
       stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗
       (∀ (ex : execution_trace Λ) (atr : auxiliary_trace AS)
            δ' c,
         ⌜valid_system_trace ex atr⌝ -∗
         ⌜trace_starts_in ex ([e1], σ1)⌝ -∗
         ⌜trace_starts_in atr δ1⌝ -∗
         ⌜trace_ends_in ex c⌝ -∗
         ⌜trace_ends_in atr δ'⌝ -∗
         ⌜∀ ex' atr' oζ ℓ,
             trace_contract ex oζ ex' → trace_contract atr ℓ atr' →
          φ ex' atr' ∧
          valid_state_evolution ex' atr' oζ ℓ (trace_last ex) (trace_last atr)⌝ -∗
         ⌜∀ e2, s = NotStuck → e2 ∈ c.1 → not_stuck e2 c.2⌝ -∗
         stateI ex atr -∗
         (* posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop 1 c.1)))) -∗ *)
         posts_of c.1 (Φ  :: (map (λ '(tnew, e), fork_post (locale_of tnew e)) (prefixes_from [e1] (drop (length [e1]) c.1)))) -∗
         □ (stateI ex atr ∗
             (∀ ex' atr' oζ ℓ, ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
            ={⊤}=∗ stateI ex atr ∗ trace_inv ex atr) ∗
         ((∀ ex' atr' oζ ℓ,
              ⌜trace_contract ex oζ ex'⌝ → ⌜trace_contract atr ℓ atr'⌝ → trace_inv ex' atr')
          ={⊤, ∅}=∗ ⌜φ ex atr⌝))) →
  (continued_simulation φ (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∧
     adequate s e1 σ1 (λ v _, True)).
Proof.
  intros ??. split; eauto using adequacy_xi, wp_strong_adequacy_with_trace_inv.
Qed.

Corollary wp_adequacy Λ AS Σ `{!invGpreS Σ} s e σ δ φ :
  valid_state_evolution_finitary AS (wp_adequacy_relation Λ AS s φ) →
  (∀ `{Hinv : !invGS Σ},
     ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (fork_post : locale Λ -> val Λ → iProp Σ),
       let _ : irisG Λ AS Σ :=
           IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗ stateI (trace_singleton ([e], σ)) (trace_singleton δ) ∗
       WP e @ s; locale_of [] e; ⊤ {{ v, ⌜φ v⌝ }}) →
  adequate s e σ (λ v _, φ v).
Proof.
  intros ? Hwp.
  apply (wp_adequacy_relation_adequacy (AS := AS) _ _ _ δ _ (wp_adequacy_relation _ AS s φ)) =>//.
  apply (wp_strong_adequacy Λ AS Σ s); first done.
  iIntros (?) "".
  iMod Hwp as (stateI fork_post) "(config_wp & HSI & Hwp)".
  iModIntro; iExists _, _, _; iFrame.
  iIntros (ex atr δ' c Hvlt Hexs Hatrs Hexe Hatre Hψ Hnst) "HSI Hposts".
  iApply fupd_mask_intro_discard; first done.
  iIntros (c' Hc').
  assert (c' = c) as -> by by eapply trace_ends_in_inj.
  iSplit; last done.
  iIntros (v2 t2 ->); rewrite /= to_of_val /=.
  iDestruct "Hposts" as "[% ?]"; done.
Qed.

Local Definition wp_invariance_relation Λ AS e1 σ1 t2 σ2 (φ : Prop)
           (ex : execution_trace Λ) (atr : @auxiliary_trace Λ AS) : Prop :=
  trace_starts_in ex ([e1], σ1) → trace_ends_in ex (t2, σ2) → φ.

Local Lemma wp_invariance_relation_invariance {Λ AS} e1 σ1 δ1 t2 σ2 φ :
  continued_simulation
    (wp_invariance_relation Λ AS e1 σ1 t2 σ2 φ)
    (trace_singleton ([e1], σ1))
    (trace_singleton δ1) →
  ∀ ex,
    valid_exec ex →
    trace_starts_in ex ([e1], σ1) →
    trace_ends_in ex (t2, σ2) →
    φ.
Proof.
  intros Hsm ex Hex Hexstr Hexend.
  eapply simulation_does_continue in Hsm as [atr [? Hatr]]; eauto.
  rewrite -> continued_simulation_unfold in Hatr.
  destruct Hatr as (Hvlt & Hψ & Hatr).
  apply Hψ; done.
Qed.

Corollary wp_invariance Λ AS Σ `{!invGpreS Σ} s e1 σ1 δ1 t2 σ2 φ :
  valid_state_evolution_finitary AS (wp_invariance_relation _ _ e1 σ1 t2 σ2 φ) →
  (∀ `{Hinv : !invGS Σ},
     ⊢ |={⊤}=> ∃
         (stateI : execution_trace Λ → auxiliary_trace AS → iProp Σ)
         (fork_post : locale Λ -> val Λ → iProp Σ),
       let _ : irisG Λ AS Σ := IrisG _ _ _ Hinv stateI fork_post in
       config_wp ∗ stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗
       WP e1 @ s; locale_of [] e1; ⊤ {{ _, True }} ∗
       (∀ ex atr,
           ⌜valid_system_trace ex atr⌝ →
           ⌜trace_starts_in ex ([e1], σ1)⌝ →
           ⌜trace_starts_in atr δ1⌝ →
           ⌜trace_ends_in ex (t2, σ2)⌝ →
           stateI ex atr -∗ ∃ E, |={⊤,E}=> ⌜φ⌝)) →
  ∀ ex,
    valid_exec ex →
    trace_starts_in ex ([e1], σ1) →
    trace_ends_in ex (t2, σ2) →
    φ.
Proof.
  intros ? Hwp.
  apply (wp_invariance_relation_invariance _ _ δ1).
  apply (wp_strong_adequacy Λ AS Σ s); first done.
  iIntros (?) "".
  iMod Hwp as (stateI fork_post) "(config_wp & HSI & Hwp & Hφ)".
  iModIntro; iExists _, _, _; iFrame.
  iIntros (ex atr δ' c Hvlt Hexs Hatrs Hexe Hatre Hψ Hnst) "HSI Hposts".
  rewrite /wp_invariance_relation.
  iAssert ((∀ _ : trace_starts_in ex ([e1], σ1) ∧ trace_ends_in ex (t2, σ2),
                 |={⊤}=> ⌜φ⌝)%I) with "[HSI Hφ]" as "H".
  { iIntros ([? ?]).
    assert (c = (t2, σ2)) as -> by by eapply trace_ends_in_inj.
    iDestruct ("Hφ" with "[] [] [] [] HSI") as (E) "Hφ"; [done|done|done|done|].
    iDestruct (fupd_plain_mask with "Hφ") as ">Hφ"; done. }
  rewrite -fupd_plain_forall'.
  iMod "H".
  iApply fupd_mask_intro_discard; first done.
  iIntros (Hexs' Hexe'); iApply "H"; done.
Qed.


(** * Definition of the generic part of the interface of the correctness proof of the CFG parser *)
Require Import Coq.Strings.String.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Arith.EqNat.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.GenericBaseTypes.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.StringLike.Core.

Set Implicit Arguments.

Section correctness.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {predata : @parser_computational_predataT Char}
          {gendata : @generic_parser_dataT Char}.

  Class generic_parser_decidable_data {gendata : @generic_parser_dataT Char} :=
    {
      parse_nt_T_to_bool : parse_nt_T -> bool;
      parse_item_T_to_bool : parse_item_T -> bool;
      parse_production_T_to_bool : parse_production_T -> bool;
      parse_productions_T_to_bool : parse_productions_T -> bool
    }.

  Class generic_parser_decidable_correctness_data {gendata : @generic_parser_dataT Char} {gddata : generic_parser_decidable_data} :=
    {
      ret_Terminal_true_to_bool
      : forall ch, parse_item_T_to_bool (ret_Terminal_true ch) = true;
      ret_Terminal_false_to_bool
      : forall ch, parse_item_T_to_bool (ret_Terminal_false ch) = false;
      ret_NonTerminal_true_to_bool
      : forall nt rv, parse_item_T_to_bool (ret_NonTerminal_true nt rv) = parse_nt_T_to_bool rv;
      ret_NonTerminal_false_to_bool
      : forall nt, parse_item_T_to_bool (ret_NonTerminal_false nt) = false;
      ret_production_nil_true_to_bool
      : parse_production_T_to_bool ret_production_nil_true = true;
      ret_production_nil_false_to_bool
      : parse_production_T_to_bool ret_production_nil_false = false;
      ret_orb_production_base_to_bool
      : parse_production_T_to_bool ret_orb_production_base = false;
      ret_orb_production_to_bool
      : forall rv1 rv2, parse_production_T_to_bool (ret_orb_production rv1 rv2)
                        = orb (parse_production_T_to_bool rv1) (parse_production_T_to_bool rv2);
      ret_production_cons_to_bool
      : forall rv1 rv2, parse_production_T_to_bool (ret_production_cons rv1 rv2)
                        = andb (parse_item_T_to_bool rv1) (parse_production_T_to_bool rv2);
      ret_orb_productions_base_to_bool
      : parse_productions_T_to_bool ret_orb_productions_base = false;
      ret_orb_productions_to_bool
      : forall rv1 rv2, parse_productions_T_to_bool (ret_orb_productions rv1 rv2)
                        = orb (parse_production_T_to_bool rv1) (parse_productions_T_to_bool rv2);
      ret_nt_to_bool
      : forall v, parse_nt_T_to_bool (ret_nt v) = parse_productions_T_to_bool v;
      ret_nt_invalid_to_bool
      : parse_nt_T_to_bool ret_nt_invalid = false
    }.
End correctness.

Create HintDb generic_parser_decidable_correctness discriminated.
Hint Rewrite @ret_Terminal_true_to_bool @ret_Terminal_false_to_bool @ret_NonTerminal_true_to_bool @ret_NonTerminal_false_to_bool @ret_production_nil_true_to_bool @ret_production_nil_false_to_bool @ret_orb_production_base_to_bool @ret_orb_production_to_bool @ret_production_cons_to_bool @ret_orb_productions_base_to_bool @ret_orb_productions_to_bool @ret_nt_to_bool @ret_nt_invalid_to_bool : generic_parser_decidable_correctness.

Lemma fold_right_ret_orb_production_eq
      {Char}
      {gendata : @generic_parser_dataT Char}
      {gddata : generic_parser_decidable_data}
      {gdcdata : generic_parser_decidable_correctness_data}
      ls b
  : parse_production_T_to_bool (List.fold_right ret_orb_production b ls)
    = List.fold_right orb (parse_production_T_to_bool b) (List.map parse_production_T_to_bool ls).
Proof.
  revert b; induction ls as [|?? IHls]; simpl; trivial; intros; [].
  rewrite <- IHls; clear IHls.
  autorewrite with generic_parser_decidable_correctness; trivial.
Qed.

Lemma fold_right_ret_orb_productions_eq
      {Char}
      {gendata : @generic_parser_dataT Char}
      {gddata : generic_parser_decidable_data}
      {gdcdata : generic_parser_decidable_correctness_data}
      ls b
  : parse_productions_T_to_bool (List.fold_right ret_orb_productions b ls)
    = List.fold_right orb (parse_productions_T_to_bool b) (List.map parse_production_T_to_bool ls).
Proof.
  revert b; induction ls as [|?? IHls]; simpl; trivial; intros; [].
  rewrite <- IHls; clear IHls.
  autorewrite with generic_parser_decidable_correctness; trivial.
Qed.

Hint Rewrite @fold_right_ret_orb_production_eq @fold_right_ret_orb_productions_eq : generic_parser_decidable_correctness.


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.Sub0282a.BaseDefs.
Require Import BetaJulia.Sub0282a.BaseProps.
Require Import BetaJulia.Sub0282a.BaseMatchProps.
Require Import BetaJulia.Sub0282a.BaseSemSubProps.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Lemma build_v_full :
  forall (X X' : id) (tx : ty) (w : nat) (t v : ty),
  wf_ty tx ->
  b_free_in_ty X t ->
  |-[ w] v <$ [BX := tx] t ->
  exists v' : ty,
    |-[ w] v' <$ [BX := TFVar X'] t /\
    (forall w' : nat,
     exists w2 : nat,
       forall t' : ty, |-[ w'] v' <$ t' -> (not_f_free_in_ty X' t' -> |-[ w'] v <$ t') /\ (f_free_in_ty X' t' -> |-[ w2] v <$ [FX' := tx] t')).
Proof.
(intros X X' tx).
(induction w; induction t; intros v Hwftx HX Hm;
  try (solve [ unfold b_free_in_ty, free in HX; simpl in HX; rewrite IdSetFacts.empty_iff in HX; contradiction ])).
-
admit.
-
admit.
-
(destruct (beq_idP X i)).
+
subst.
(rewrite b_subst_exist_eq in Hm).
(apply match_ty_exist__0_inv in Hm).
contradiction.
+
subst.
(rewrite b_subst_exist_neq in Hm; try assumption).
(apply match_ty_exist__0_inv in Hm).
contradiction.
-
(* Auto-generated comment: Succeeded. *)


(** * Parallel.v : describing parallel quantum programs *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality.

From Babel Require Import QTheory POrderFacility POrderSet POrderNat
                            nd_seq.

From Babel.Ranko Require Import CentralCharacter.

From Coq Require Import Classical Arith Relations Reals.

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

Module QParallelProg

(** This Module relies on a basic theory of quantum, *)
                     (QTB : QTheoryBasicType)

(** and a theory to combine sets into quantums. *)
                     (QTS : QTheorySetType QTB).

(** Get the extended theory of quantum sets *)
Module Import QTS_ext := QTheorySet QTB QTS.

(** use the number order *)
Import NatLePoset.CanonicalStruct.
Import SubsetOrder.CanonicalStruct.

Declare Scope QPP_scope.
Open Scope QPP_scope.

(** A legal parallel quantum program (after syntax check) *)
Inductive prog (qs : QvarScope): Type :=
| skip_
| abort_
| init_ (qv : qs)
| unitary_ (qv : qs) (U : UnitaryOpt qv)
| if_ (qv_m : qs) (m : MeaOpt qv_m) (S0 S1: prog qs)
| while_ (qv_m : qs) (m : MeaOpt qv_m) (S0 : prog qs)
| seq_ (S1 S2 : prog qs)
| prob_ (p : [0, 1]R) (S1 S2 : prog qs)
| nondet_ (S1 S2 : prog qs)
| atom_ (S0 : prog qs)
| parallel_ (S1 S2 : prog qs).

Notation " 'Skip' " := (@skip_ _) : QPP_scope.
Notation " 'Abort' " := (@abort_ _) : QPP_scope.
Notation " qv <- '0' " := (@init_ _ qv) (at level 10) : QPP_scope.
Notation " qv *= U " := (@unitary_ _ qv U) (at level 10) : QPP_scope.
Notation " 'If' m [[ qv_m ]] 'Then' S0 'Else' S1 'End' " :=
    (@if_ _ qv_m m S0 S1) (at level 90) : QPP_scope.
Notation " 'While' m [[ qv_m ]] 'Do' S0 'End' " :=
    (@while_ _ qv_m m S0) (at level 90) : QPP_scope.
Notation " S1 ; S2 " := (@seq_ _ S1 S2)
    (at level 95, right associativity) : QPP_scope.
Notation " S1 [ p ⊕ ] S2 " := (@prob_ _ p S1 S2)
    (format "S1  [ p  ⊕ ]  S2"): QPP_scope.
Notation " S1 □ S2 " := (@nondet_ _ S1 S2) (at level 3): QPP_scope.
Notation " << P >> " := (@atom_ _ P) : QPP_scope.
Notation " [ S1 // S2 ] " := (@parallel_ _ S1 S2) (at level 0) : QPP_scope.

Fixpoint non_parallel {qs : QvarScope} (P : prog qs) : bool :=
    match P with
    | [S1 // S2] => false
    | If m [[ qv_m ]] Then S0 Else S1 End => non_parallel S0 && non_parallel S1
    | While m [[ qv_m ]] Do S0 End => non_parallel S0
    | S1 ; S2 => non_parallel S1 && non_parallel S2
    | _ => true
    end.

(** Get the quantum variable of the program *)
Fixpoint qvar_of_prog {qs : QvarScope} (S0 : prog qs) : qs :=
    match S0 with
    | Skip => em_var _
    | Abort => em_var _
    | qv <- 0 => qv
    | qv *= _ => qv
    | If _ [[ qv_m ]] Then S0 Else S1 End
        => qv_m [+] (qvar_of_prog S0) [+] (qvar_of_prog S1)
    | While _ [[ qv_m ]] Do S0 End
        => qv_m [+] (qvar_of_prog S0)
    | S1;S2 => (qvar_of_prog S1) [+] (qvar_of_prog S2)
    | S1 [ p ⊕ ] S2 => (qvar_of_prog S1) [+] (qvar_of_prog S2)
    | S1 □ S2 =>(qvar_of_prog S1) [+] (qvar_of_prog S2)
    | <<S0>> => qvar_of_prog S0
    | [ S1 // S2 ] => (qvar_of_prog S1) [+] (qvar_of_prog S2)
    end.
Coercion qvar_of_prog : prog >-> Qvar.

Fixpoint seq_Head {qs : QvarScope} (S0 : prog qs) : prog qs :=
    match S0 with
    | P0 ; P1 => seq_Head P0
    | _ => S0
    end.
Fixpoint seq_Tail {qs : QvarScope} (S0 : prog qs) : option (prog qs) :=
    match S0 with
    | P0 ; P1 => match seq_Tail P0 with
                  | None => Some P1
                  | Some Q => Some (Q ; P1)
                  end
    | _ => None
    end.

(** Refine the step statement *)
(** make a choice for the parallel component program *)
Definition Step {qs : QvarScope} (S1 S2: prog qs)
              (b : bool) : prog qs :=
    if b then
        match seq_Tail S1 with
        | None => (* if S1 is not a sequence *)
            match S1 with
            | If m [[ qv_m ]] Then P0 Else P1 End =>
                If m [[ qv_m ]] Then [ P0 // S2 ] Else [ P1 // S2 ] End
            | While m [[ qv_m ]] Do P0 End =>
                If m [[ qv_m ]] Then [ P0 ; While m [[qv_m]] Do P0 End // S2 ]
                                Else [ Skip // S2] End
            | _ => S1 ; [ Skip // S2 ]
            end
        (** Note that here we give a different interpretation of
            nested parallel composition
            We consider the inner parallel composition as a 'atomic' action
            performed in parallel *)
        | Some Q => seq_Head S1 ; [ Q // S2 ]
        end
    else
        match seq_Tail S2 with
        | None => (* if S2 is not a sequence *)
            match S2 with
            | If m [[ qv_m ]] Then P0 Else P1 End =>
                If m [[ qv_m ]] Then [ S1 // P0 ] Else [ S1 // P1 ] End
            | While m [[ qv_m ]] Do P0 End =>
                If m [[ qv_m ]] Then [ S1 // P0 ; While m [[qv_m]] Do P0 End ]
                                Else [ S1 // Skip] End
            | _ => S2 ; [ S1 // Skip ]
            end
        (** Note that here we give a different interpretation of
            nested parallel composition *)
        | Some Q => seq_Head S2 ; [ S1 // Q ]
    end.
Arguments Step : simpl nomatch.
(* ############################################################ *)
(** ** Operational Semantics *)

(** The configuration of computation *)
Inductive cfg (qs : QvarScope): Type :=
| Srho_pair (S0 : prog qs) (rho : 𝒟( qs )⁻ )
| Terminated (rho : 𝒟( qs )⁻ ).
Notation " <{ S0 , rho }> " := (@Srho_pair _ S0 rho ) : QPP_scope.
Notation " <{ '↓' , rho }> " := (@Terminated _ rho) : QPP_scope.

Reserved Notation " c1 -=> c2 " (at level 20).
Reserved Notation " c1 -=>* c2 " (at level 20).

Inductive opSem_trans qs : cfg qs -> cfg qs -> Prop :=
| skip_step rho :
    <{ Skip, rho }> -=> <{ ↓, rho }>

| abort_step rho:
    <{ Abort, rho }> -=> <{ ↓, 𝟎 }>

| init_step qv rho:
    <{ qv <- 0, rho }> -=> <{ ↓, InitStt qv rho }>

| unitary_step qv U rho:
    <{ qv *= U, rho }> -=> <{ ↓, Uapply U rho }>

| if_step_Y qv_m m S0 S1 rho:
    <{ If m [[qv_m]] Then S0 Else S1 End, rho }>
    -=> <{ S0, Mapply m true rho }>

| if_step_N qv_m m S0 S1 rho:
    <{ If m [[qv_m]] Then S0 Else S1 End, rho }>
        -=> <{ S1, Mapply m false rho }>

| while_step_Y qv_m m S0 rho:
    <{ While m [[qv_m]] Do S0 End, rho }>
        -=> <{ S0 ; While m [[qv_m]] Do S0 End, Mapply m true rho }>

| while_step_N qv_m m S0 rho:
    <{ While m [[qv_m]] Do S0 End, rho }>
        -=> <{ ↓, Mapply m true rho }>

| seq_step_p S0 St S1 rho0 rho1:
    <{ S0, rho0 }> -=> <{ St, rho1 }>
    -> <{ S0 ; S1, rho0 }> -=> <{ St ; S1, rho1 }>

| seq_step_t S0 S1 rho0 rho1:
    <{ S0, rho0 }> -=> <{ ↓, rho1 }>
        -> <{ S0 ; S1, rho0 }> -=> <{ S1, rho1 }>

| atom_step S0 rho0 rho1 :
    <{ S0, rho0 }> -=>* <{ ↓, rho1 }>
        -> <{ <<S0>>, rho0 }> -=> <{ ↓, rho1 }>

| parallel_step_0 S0 S1 rho :
    <{ [S0 // S1], rho }> -=> <{ Step S0 S1 true, rho }>

| parallel_step_1 S0 S1 rho :
    <{ [S0 // S1], rho }> -=> <{ Step S0 S1 false, rho }>

where " c1 -=> c2 " := (opSem_trans c1 c2)
    and " c1 -=>* c2 " := (clos_trans _ (@opSem_trans _) c1 c2).

(* ############################################################ *)
(** ** Denotational Semantics *)

Reserved Notation " ⦗ P , n ⦘ ( rho ) "
    (at level 10, rho at next level, format "⦗  P ,  n  ⦘ ( rho )").

Reserved Notation " ⦗ P , n ⦘ "
    (at level 10, format "⦗  P ,  n  ⦘").

Reserved Notation " ⦗ ↓ ⦘ ( rho ) "
    (at level 10, rho at next level, only printing, format "⦗  ↓  ⦘ ( rho )").

Reserved Notation " ⦗ ↓ ⦘"
    (at level 10, only printing, format "⦗  ↓  ⦘").

(** Define the denotational semantics of calculating n steps
    parameter :
        [P : option (prog qs)], if [P] is [None] then the program is
            terminated.*)
Fixpoint deSemN_point {qs : QvarScope} (P : option (prog qs)) (n : nat)
    (rho : 𝒟( qs )⁻) : 𝒫(𝒟( qs )⁻) :=
    match P with
    | None => {{ rho }}
    | Some P =>
        match n with
        | 0 => ∅
        | n'.+1 =>
            match P with
            | Skip =>
                {{ rho }}

            | Abort =>
                𝕌

            | qv <- 0 =>
                {{ InitStt qv rho }}

            | qv *= U =>
                {{ Uapply U rho }}

            | If m [[ qv_m ]] Then P0 Else P1 End =>
                (⦗ P0, n' ⦘ ( Mapply m true rho ))
                + (⦗ P1, n' ⦘ ( Mapply m false rho ))

            | While m [[ qv_m ]] Do P0 End  =>
                ⦗ P0; While m [[ qv_m ]] Do P0 End, n' ⦘ (Mapply m true rho)
                + {{ Mapply m false rho }}

            | S1 ; S2 =>
                ⋃ { ⦗ S2, n' ⦘ (rho') , rho' | rho' ∈ ⦗ S1, n' ⦘ (rho) }

            | S1 [ p ⊕ ] S2 =>
                (⦗ S1, n' ⦘( rho )[ p ⊕ ] ⦗ S2, n' ⦘( rho ))%QTS

            | S1 □ S2 =>
                ⦗ S1, n' ⦘(rho) ∪ ⦗ S2, n' ⦘(rho)

            | << P >> =>
                ⦗ P, n' ⦘ (rho)

            | [ S1 // S2 ] =>
                (** Note that here we give a different interpretation of
                    nested parallel composition *)
                (⦗ Step S1 S2 true, n' ⦘ (rho))
                ∪ (⦗ Step S1 S2 false, n' ⦘ (rho))

            end
        end
    end
    where " ⦗ P , n ⦘ " := (deSemN_point (Some P) n) : QPP_scope and
    " ⦗ P , n ⦘ ( rho ) " := (deSemN_point (Some P) n rho) : QPP_scope.

Arguments deSemN_point : simpl nomatch.

Notation " ⦗ ↓ ⦘ ( rho ) " := (deSemN_point None _ rho) :QPP_scope.
Notation " ⦗ ↓ ⦘ " := (deSemN_point None _ ) :QPP_scope.

(** lift to set input *)
Definition deSemN {qs : QvarScope} (P : prog qs) (n : nat) := ⋃ ◦ ⦗ P, n ⦘ [<].

Notation " ⟦ P , n ⟧ " := (deSemN P n)
    (at level 10, format "⟦  P ,  n  ⟧") : QPP_scope.

Notation " ⟦ P , n ⟧ ( rho_s ) " := (deSemN P n rho_s)
    (at level 10, rho_s at next level,
    format "⟦  P ,  n  ⟧ ( rho_s )") : QPP_scope.

(*
(** Prove that [⦗ P , n ⦘ ( rho )] is always nonempty. *)
Lemma deSemN_point_nemMixin {qs : QvarScope} (P : prog qs) (n : nat) rho :
    NemSet.class_of (⦗ P , n ⦘ (rho)).
Proof.
    rewrite /NemSet.mixin_of. elim: n P rho.
    move => P rho //=. apply uni_neq_em.

    (** induction step *)
    move => n IHn. case => //=.

    (** skip, abort, init, unitary *)
    1,2,3,4 : intros; apply NemSet.class.

    (** if *)
    move => qv_m m S0 S1 rho.
    by apply add_set_nem; apply IHn.

    (** while *)
    move => qv_m m S0 rho.
    apply add_set_nem. by apply IHn. by apply NemSet.class.

    (** sequence *)
    move => S1 S2 rho.
    apply bigU_nemP. apply forall_to_exists_nonempty.
    rewrite mapR_eq_emP. by apply IHn.
    move => //= A [] x [_ Hx]. rewrite -Hx. by apply IHn.

    (** probability *)
    move => p S1 S2 rho.
    apply scalar_convex_combS_nemMixin; by apply IHn.

    (** nondeterministic *)
    move => S1 S2 rho.
    apply union_nem_L. by apply IHn.

    (** parallel *)
    move => S1 S2 rho.
    apply union_nem_L. by apply IHn.
Qed.

(** Prove that [⟦ P , n ⟧ (rho_s)] is always nonempty. *)

Lemma deSemN_nemMixin {qs : QvarScope} (P : prog qs) (n : nat)
    (rho_s : 𝒫(𝒟( qs )⁻)) (Hnem : NemSet.class_of rho_s) :
        NemSet.class_of (⟦ P , n ⟧ (rho_s)).
Proof.
    rewrite /NemSet.mixin_of /deSemN.
    apply bigU_nemP. apply forall_to_exists_nonempty.
    by rewrite mapR_eq_emP.
    move => A [] x [_ Hx]. rewrite -Hx. by apply deSemN_point_nemMixin.
Qed.

Canonical deSemN_nemType
    {qs : QvarScope} (P : prog qs) (n : nat) (rho_s : 𝒫(𝒟( qs )⁻)₊) :=
        NemSet _ (@deSemN_nemMixin _ P n _ (NemSet.class rho_s)).
*)

Section DeSemPointStep.

Variable (qs : QvarScope) (rho : 𝒟( qs )⁻) (n : nat).

Lemma deSemN_seq_point_fun (S1 S2 : prog qs):

    ⦗ S1 ; S2, n.+1 ⦘ = ⋃ ◦ ⦗ S2, n ⦘ [<] ◦ ⦗ S1, n ⦘.

Proof. by []. Qed.

End DeSemPointStep.

Section DeSemStep.

Variable (qs : QvarScope) (rho_s : 𝒫(𝒟( qs )⁻)₊).
(*

Lemma deSemN_skip n:

            ⟦ Skip, n.+1 ⟧(rho_s) = rho_s.

Proof.
    rewrite /deSemN /fun_comp /mapR //=.
    by rewrite bigU_rei.
Qed.

Lemma deSemN_abort n:

            ⟦ Abort, n ⟧(rho_s) = 𝕌.

Proof.
    rewrite /deSemN /fun_comp /mapR //=.
    case: n => //=.
    rewrite bigU_sgt_nem => //. apply NemSet.class.
    rewrite bigU_sgt_nem => //=. by apply NemSet.class.
Qed.

Lemma deSemN_init qv n:

            ⟦ qv <-0 , n.+1 ⟧(rho_s) = (InitStt qv) [<] rho_s.

Proof.
    rewrite /deSemN /fun_comp /mapR //=.
    by rewrite bigU_fun_rei.
Qed.

Lemma deSemN_unitary qv U n:

            ⟦ qv *= U , n.+1 ⟧(rho_s) = (Uapply U) [<] rho_s.

Proof.
    rewrite /deSemN /mapR //=.
    by apply bigU_fun_rei.
Qed.
Lemma deSemN_if qv_m m S0 S1 n:

            ⟦ If m [[ qv_m ]] Then S0 Else S1 End, n.+1 ⟧ (rho_s)
            = ( ⟦ S0 , n ⟧ ((Mapply m true) [<] rho_s)
            + ⟦ S1 , n ⟧ ((Mapply m false) [<] rho_s) )%QTS.

Proof.

    rewrite /deSemN /fun_comp /mapR //=.

Abort.

Lemma deSemN_while qv_m m S0 n:

            ⟦ While m [[ qv_m ]] Do S0 End, n.+1 ⟧ (rho_s)
            = ( ⟦ S0 ; While m [[ qv_m ]] Do S0 End, n ⟧ (MapplyS m true rho_s)
            + MapplyS m false rho_s )%QTS.

Proof.
    rewrite /deSemN //=.
Abort.

Lemma deSemN_seq S0 S1 n:

            ⟦ S0 ; S1, n.+1 ⟧ (rho_s) = ⟦ S1 , n ⟧ (⟦ S0, n ⟧ (rho_s)).

Proof.
    equal_f_comp rho_s.
    rewrite /deSemN deSemN_seq_point_fun.

    rewrite -[RHS]fun_assoc
        [(⋃ ◦ ⦗ S1, n ⦘ [<]) ◦ ⋃] fun_assoc.
    rewrite mapR_bigU_swapF.
    rewrite -bigU_fun_distF.
    rewrite -[⋃ ◦ ⦗ S1, n ⦘ [<] ◦ ⦗ S0, n ⦘]fun_assoc.
    rewrite -double_mapRF.
    by rewrite fun_assoc.
Qed.

Lemma deSemN_prob p S1 S2 n:

        ⟦ S1 [p ⊕] S2, n.+1 ⟧(rho_s)
        = (⟦ S1, n ⟧( rho_s )[ p ⊕ ] ⟦ S2, n ⟧( rho_s ))%QTS.

Proof.
Abort.
*)

Lemma deSemN_nondet S1 S2 n:
        ⟦ S1 □ S2, n.+1 ⟧(rho_s) = ⟦ S1, n ⟧(rho_s) ∪ ⟦ S2, n ⟧(rho_s).
Proof.
    rewrite /deSemN /mapR => //=.
    by rewrite union_bigU_mapR_dist.
Qed.

Lemma deSemN_atom P n:
        ⟦ <<P>>, n.+1 ⟧(rho_s) = ⟦ P, n ⟧(rho_s).
Proof. by []. Qed.

Lemma deSemN_parallel S1 S2 n:
        ⟦ [ S1 // S2], n.+1 ⟧(rho_s)
        =  (⟦ Step S1 S2 true, n ⟧(rho_s)) ∪ (⟦ Step S1 S2 false, n ⟧(rho_s)).
Proof.
    rewrite /deSemN /mapR.
    by rewrite union_bigU_mapR_dist.
Qed.

End DeSemStep.

Lemma deSem0 (qs : QvarScope) P (rho_s : 𝒫(𝒟( qs )⁻)) :

        ⟦ P , 0 ⟧ (rho_s) = ∅.

Proof.
    rewrite /deSemN /fun_comp /mapR //=.
    case (em_classic rho_s).
    move => ->. by apply bigU_sgt_em.
    move => ?. by apply bigU_sgt_nem.
Qed.

Lemma deSem_em (qs : QvarScope) (P : prog qs) n :

        ⟦ P , n ⟧ (∅) = ∅.

Proof.
    rewrite /deSemN /fun_comp => //=.
    rewrite mapR_em. by apply big_union_em.
Qed.

Lemma deSemN_monotonicMixin {qs : QvarScope} (P : prog qs) (n : nat) :
    MonotonicFun.mixin_of (⟦ P, n ⟧).
Proof.
    rewrite /MonotonicFun.mixin_of => A B HAinB.

    (** prove the special cases *)
    case: n. by rewrite !deSem0.
    move => n.
    case: (em_classic A); case: (em_classic B).
    move => -> ->. by rewrite deSem_em.
    move => _ ->. by rewrite deSem_em.
    move => HB HA. rewrite HB //= in HAinB.
        rewrite /ord_op //= in HAinB.
        rewrite subset_emP in HAinB. by destruct (HA HAinB).

    move => HB HA.

    rewrite /deSemN /fun_comp.

    case P; rewrite /mapR //=; intros; apply bigU_mor_sub;
    by apply mapR_mor_sub.
Qed.

Canonical deSemN_monotonicfun {qs : QvarScope} (P : prog qs) (n : nat) :=
    MonotonicFun _ (@deSemN_monotonicMixin qs P n).

Lemma deSemN_continuousMixin {qs : QvarScope} (P : prog qs) (n : nat) :
    ContinuousFun.mixin_of (MonotonicFun.class (⟦ P, n ⟧)).
Proof.
    rewrite /ContinuousFun.mixin_of //= => c.
    rewrite /monotonic_mapR_chain  /CPO.join_op  //=.
    rewrite /deSemN.
    equal_f_comp c.
    (** LHS *)
    rewrite -fun_assoc.
    rewrite [((⋃ ◦ ⦗ P, n ⦘ [<]) ◦ ⋃)]fun_assoc.
    rewrite mapR_bigU_swapF.
    (** RHS *)
    rewrite -[in RHS]fun_assoc.
    rewrite bigU_fun_distF.
    by [].
Qed.

(* The strong relation between opSemN and order *)
Lemma deSemN_point_monotonic_strong {qs : QvarScope} :
    forall (S0 : prog qs) (rho : 𝒟( qs )⁻) n i,
        (i <= n)%nat -> ⦗ S0, i ⦘ (rho) ⊆ ⦗ S0, n ⦘ (rho).
Proof.
    move => S0 rho n.

    (* induction on n *)
    elim: n S0 rho.
    (* induction basis, n = 0*)
    move => S0 rho i. by rewrite leqn0 => /eqP ->.

    (* induction step, process i=0 first *)
    move => n IHn S0 rho i Hi. case: i Hi.
    by move => _.

    move => i Hi.
    (* case on programs *)
    case: S0.
    (* skip abort, init, unitary *)
    1,2,3,4: by intros.
    (* if *)
    move => qv_m m S0 S1.
    by apply PDenSetOrder_add_split; apply /IHn.
    (* while *)
    move => qv_m m S0 /=.
    apply PDenSetOrder_add_split; last first => //.
    by apply IHn.
    (* sequence *)
    move => S1 S2 /=.
    apply bigU_mapR_mor_sub.
    by apply IHn.
    move => t. by apply IHn.
    (* probability *)
    move => p S1 S2 /=.
    apply PDensetOrder_cv_comb_split; by apply IHn.
    (* nondet *)
    move => S1 S2 /=.
    apply PDenSetOrder_union_split; by apply IHn.
    (* atom *)
    move => S0 /=. by apply IHn => //.
    (* parallel *)
    move => S1 S2 /=.
    apply PDenSetOrder_union_split; by apply IHn.
Qed.

Lemma deSemN_point_monotonic_step {qs : QvarScope} (P : prog qs) rho:
    forall n, ⦗ P, n ⦘ (rho) ⊆ ⦗ P, n.+1 ⦘ (rho).
Proof. move => n. by apply deSemN_point_monotonic_strong. Qed.
Arguments deSemN_point_monotonic_step {qs} P rho.

(* The strong relation between deSemN and order *)
Lemma deSemN_monotonic_strong {qs : QvarScope}:
    forall (S0 : prog qs) (r1 r2 : 𝒫(𝒟( qs )⁻)) (n i : nat),
        (i <= n)%nat -> r1 ⊆ r2 -> ⟦ S0, i ⟧ (r1) ⊆ ⟦ S0, n ⟧ (r2).
Proof.
    rewrite /deSemN => S0 r1 r2 n i Hi Hr1r2.
    apply bigU_mapR_mor_sub => // t.
    by apply deSemN_point_monotonic_strong.
Qed.

Lemma deSemN_monotonic_rho {qs : QvarScope} :
    forall (S0 : prog qs) (r1 r2 : 𝒫(𝒟( qs )⁻)) n,
        r1 ⊆ r2 -> ⟦ S0, n ⟧ (r1) ⊆ ⟦ S0, n ⟧ (r2).
Proof.
    move => S0 r1 r2 n.
    by apply (@deSemN_monotonic_strong qs S0 r1 r2 n n).
Qed.

(** Prove that [opSemN c i] is increasing when i increases. *)
Lemma deSemN_monotonic_N {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)):
    forall i n, (i <= n)%nat -> ⟦ P, i ⟧ (rho_s) ⊆ ⟦ P, n ⟧ (rho_s).
Proof. move => i n Hin.
    by apply deSemN_monotonic_strong.
Qed.

Lemma deSemN_monotonic_step {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)):
    forall n, ⟦ P, n ⟧ (rho_s) ⊆ ⟦ P, n.+1 ⟧ (rho_s).
Proof. move => n. by apply deSemN_monotonic_strong. Qed.
Arguments deSemN_monotonic_step {qs} P rho_s.

(** Construct the monotonic structure *)
Definition deSemN_n {qs : QvarScope} (P : prog qs) rho_s n := deSemN P n rho_s.

Lemma deSemN_n_monotonicMixin
    {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)) :
    MonotonicFun.mixin_of (deSemN_n P rho_s).
Proof.
    rewrite /MonotonicFun.mixin_of => x y Hxy.
    rewrite /deSemN_n. apply deSemN_monotonic_N. apply /leP. by apply Hxy.
Defined.

Canonical deSemN_n_monotonic
    {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)) :=
    MonotonicFun _ (@deSemN_n_monotonicMixin _ P rho_s).

(*
Lemma deSemN_n_continuousMixin
    {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)) : True.
    ContinuousFun.mixin_of (MonotonicFun.class (deSemN_n P rho_s)).

(** Define the operationa semantics (infinite step) *)
Definition chain_deSemN {qs : QvarScope} (P : prog qs) rho_s : chain 𝒟(qs)⁻ :=
    mk_chain (deSemN_monotonic_step P rho_s).
(** Note that these two chains are different.
    One on step number, and another on ch index. *)

(* TODO we can implement a general lemma for monotonic functions *)
Lemma chain_deSemN_n {qs : QvarScope} (P : prog qs) rho_s n :
        chain_deSemN P rho_s _[n] = ⟦ P, n ⟧ (rho_s).
Proof. by []. Qed.
*)

Definition DeSem
    {qs : QvarScope} (P : prog qs) (rho_s : 𝒫(𝒟( qs )⁻)) : 𝒫(𝒟( qs )⁻) :=

        ⊔ᶜˡ ((deSemN_n P rho_s) [<] 𝕌).

Notation " ⟦ P ⟧ " := (@DeSem _ P)
        (at level 10, format "⟦  P  ⟧"): QPP_scope.
Notation " ⟦ P ⟧ ( rho_s ) " := (@DeSem _ P rho_s)
    (at level 10, format "⟦  P  ⟧ ( rho_s )"): QPP_scope.

Lemma DeSem_monotonicMixin {qs : QvarScope} (P : prog qs) :
    MonotonicFun.mixin_of (⟦ P ⟧).
Proof.
    rewrite /MonotonicFun.mixin_of //= => A B HAB.
    rewrite !/DeSem /CLattice.join_op //=.
    apply bigU_mapR_mor_sub => //=.
    rewrite /deSemN_n => n.
    by apply (MonotonicFun.class (⟦ P, n ⟧)).
Qed.

Canonical DeSem_monotonicfun {qs : QvarScope} (P : prog qs) :=
    MonotonicFun _ (@DeSem_monotonicMixin qs P).

(*

Lemma DeSem_continuousMixin {qs : QvarScope} (P : prog qs) :
    ContinuousFun.mixin_of (MonotonicFun.class (⟦ P ⟧)).
Proof.
    rewrite /ContinuousFun.mixin_of /CPO.join_op //= => c.
    rewrite /DeSem /CLattice.join_op //=. apply poset_antisym.
    rewrite /mapR //=.
    equal_f_comp c.
    rewrite -fun_assoc.
    rewrite

Lemma DeSem_ub : forall {qs : QvarScope} n (P : prog qs) rho_s,
    ⟦ P, n ⟧ (rho_s) ⊑ ⟦ P ⟧ (rho_s).
Proof.
    rewrite /DeSem => qs n P rho_s //=.
    have t := CPO.join_prop (CPO.class _ ) [chain of ((deSemN_n P rho_s) [<] (𝕌))].
    apply t => //=.
    exists n. by split.
Qed.
Arguments DeSem_ub {qs} n P rho_s.

Lemma DeSem_lub : forall {qs : QvarScope} (P : prog qs) rho_s rho_ub,
    (forall n, ⟦ P, n ⟧(rho_s) ⊑ rho_ub) -> ⟦ P ⟧ (rho_s) ⊑ rho_ub.
Proof.
    rewrite /DeSem => qs P rho_s rho_ub H //=.
    have t := CPO.join_prop (CPO.class _ ) [chain of ((deSemN_n P rho_s) [<] (𝕌))].
    apply t => //=.

Qed.

Lemma DeSem_lubP : forall {qs : QvarScope} (P : prog qs) rho_s rho_ub,
    (forall n, ⟦ P, n ⟧(rho_s) ⊑ rho_ub) <-> ⟦ P ⟧ (rho_s) ⊑ rho_ub.
Proof. split. by apply DeSem_lub.
    move => HP n. transitivity (⟦ P ⟧ (rho_s)) => //.
    by apply DeSem_ub.
Qed.
*)

(*##################################################################*)
(* tactic *)

Ltac deSem_simpl_branch :=
    (   rewrite /deSemN_n
        || rewrite /deSemN
    ) => //=.

Ltac deSem_move_up_branch :=
    match goal with
    | H : _ = ⦗ _, _ ⦘(_) |- _ => clear H
    | H : _ = ⟦ _, _ ⟧(_) |- _ => clear H
    | n : nat |- _ ∈ ⦗ Skip , ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=
    | n : nat |- _ ∈ ⦗ Abort , ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=
    | n : nat |- _ ∈ ⦗ _ <- 0, ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=
    | n : nat |- _ ∈ ⦗ _ *= _, ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    | n : nat |- _ ∈ ⦗ If _ [[_]] Then _ Else _ End , ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    | n : nat |- _ ∈ ⦗ While _ [[_]] Do _ End , ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    (** to avoid dead loop *)
    | n : nat |- _ ∈ ⦗ _; While _ [[_]] Do _ End , ?n ⦘(_) -> _ => intros ?

    | n : nat |- _ ∈ ⦗ _; _ , ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    | n : nat |- _ ∈ ⦗ << _ >>, ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    | n : nat |- _ ∈ ⦗ [_ // _], ?n ⦘(_) -> _ =>
        generalize dependent n; case => //=

    end.

Ltac deSem_step
        top_step
        split_mode
        general_apply_depth
        eexists_mode
        :=
        match goal with
        | _ => progress repeat deSem_simpl_branch
        | _ => progress deSem_move_up_branch

        | _ => set_step top_step split_mode general_apply_depth eexists_mode
        end.

Ltac deSem_step_sealed
        split_mode
        general_apply_depth
        eexists_mode
        :=
    idtac; let rec top := deSem_step_sealed in
        deSem_step top split_mode general_apply_depth eexists_mode.

Ltac deSem_killer :=
    all_move_down;
    repeat deSem_step_sealed LAZY 100 LAZY.

(*##################################################################*)

(** Properties of Denotational Semantics *)

Lemma DeSem_skip {qs : QvarScope} (rho_s : 𝒫(𝒟( qs )⁻)₊):
    ⟦ Skip ⟧ (rho_s) = rho_s.
Proof.
    deSem_killer.
    instantiate (1:=1%nat). deSem_killer.

    (*
    rewrite /DeSem /CLattice.join_op //=. apply poset_antisym.

    apply bigU_lub => a [] i [] _ ->.
    rewrite /deSemN_n /deSemN -fun_compP.
    case: i.
    (** n = 0 *)
    rewrite /deSemN_point. rewrite /mapR.
    rewrite bigU_sgt_nem //=. by apply NemSet.class.
    (** n > 0 *)
    rewrite /mapR //= => n. by rewrite bigU_rei.

    apply bigU_ub => //=. exists 1%nat. split => //=.
    rewrite /deSemN_n /deSemN /fun_comp /mapR //=.
    by rewrite bigU_rei.
    *)
Qed.

Lemma DeSem_abort {qs : QvarScope} (rho_s : 𝒫(𝒟( qs )⁻)₊):
    ⟦ Abort ⟧ (rho_s) = 𝕌.
Proof.
    deSem_killer.
    instantiate (1:=1%nat). deSem_killer.
Qed.

Lemma DeSem_init {qs : QvarScope} qv (rho_s : 𝒫(𝒟( qs )⁻)₊):
    ⟦ qv <- 0 ⟧ (rho_s) = (InitStt qv) [<] rho_s.
Proof.
    deSem_killer.
    instantiate (1:=1%nat). deSem_killer.
Qed.

Lemma DeSem_unitary {qs : QvarScope} qv U (rho_s : 𝒫(𝒟( qs )⁻)₊):
    ⟦ qv *= U ⟧ (rho_s) = (Uapply U) [<] rho_s.
Proof.
    deSem_killer.
    instantiate (1:=1%nat). deSem_killer.
Qed.

Lemma DeSem_if {qs : QvarScope} qv_m m S0 S1 (rho_s : 𝒫(𝒟( qs )⁻)):

    ⟦ If m [[qv_m]] Then S0 Else S1 End ⟧ (rho_s)
        = ⋃ ((fun rho =>
            (⟦ S0 ⟧ ({{ Mapply m true rho }}) + ⟦ S1 ⟧ ({{ Mapply m false rho}}))) [<] rho_s).

Proof.
    deSem_killer. apply a0. apply a1.
    instantiate(1:= (Nat.max x11 x5).+1). deSem_killer.
    apply (set_belong_cut (⦗ S1, x5 ⦘((Mapply m false x1)))) => //.
    apply deSemN_point_monotonic_strong. apply /leP. apply Nat.le_max_r.
    apply (set_belong_cut (⦗ S0, x11 ⦘((Mapply m true x1)))) => //.
    apply deSemN_point_monotonic_strong. apply /leP. apply Nat.le_max_l.
Qed.

Lemma DeSem_while {qs : QvarScope} qv_m m S0 (rho_s : 𝒫(𝒟( qs )⁻)):
    ⟦ While m [[qv_m]] Do S0 End ⟧ (rho_s)
        = ⋃ (( fun rho =>
            ⟦ S0 ; While m [[qv_m]] Do S0 End ⟧ ({{ Mapply m true rho }})
            + {{ Mapply m false rho }}) [<] rho_s).
Proof.
    deSem_killer.
    apply a0.
    instantiate(1 := x7.+1 ).
    deSem_killer.
Qed.

Lemma DeSem_seq {qs : QvarScope} S1 S2 (rho_s : 𝒫(𝒟( qs )⁻)):
    ⟦ S1 ; S2 ⟧ (rho_s) =  ⟦ S2 ⟧ ( ⟦ S1 ⟧ (rho_s) ).
Proof.
    deSem_killer. apply a0.
    instantiate(1 := (max x1 x5).+1). deSem_killer.
    instantiate(1 := x3).
    apply (set_belong_cut (⦗ S1, x5 ⦘(x7))) => //.
    apply deSemN_point_monotonic_strong. apply /leP. apply Nat.le_max_r.
    apply (set_belong_cut (⦗ S2, x1 ⦘(x3))) => //.
    apply deSemN_point_monotonic_strong. apply /leP. apply Nat.le_max_l.
Qed.

Lemma DeSem_atom {qs : QvarScope} P (rho_s : 𝒫(𝒟( qs )⁻)):
    ⟦ <<P>> ⟧ (rho_s) =  ⟦ P ⟧ (rho_s).
Proof.
    deSem_killer.
    instantiate (1:=x1.+1).
    deSem_killer.
Qed.

Lemma DeSem_para {qs : QvarScope} S1 S2 (rho_s : 𝒫(𝒟( qs )⁻)):
    ⟦ [S1 // S2] ⟧ (rho_s) =
        ⟦ Step S1 S2 true ⟧ (rho_s) ∪ ⟦ Step S1 S2 false ⟧ (rho_s).
Proof.
    deSem_killer.
    all : instantiate (1:=x1.+1); deSem_killer.
Qed.

(*
(** The chain of chain_deSemN_point *)

Definition deSemN_point_map_chain
    {qs : QvarScope} (P : prog qs) ch n : chain (𝒫(𝒟(qs)⁻)) :=
    fmap_chain (⦗ P, n ⦘) ch.

(** The relation between three chains:
    - bigU chain
    - deSemN_point chain
    - deSemN chain
*)

Lemma deSem_chain_decompose
    {qs : QvarScope} (P : prog qs) rho_s n :
    deSemN_chain P rho_s n = bigU_chain (deSemN_point_map_chain P rho_s n).
Proof.
    apply chain_eqP. apply functional_extensionality => i.
    rewrite /deSemN_chain /deSemN_chain_obj {1}/chain_obj.
    rewrite /bigU_chain /bigU_chain_obj {2}/chain_obj.
    rewrite /deSemN_point_map_chain /fmap_chain /fmap_chain_obj {2}/chain_obj.
    by [].
Qed.

(*#########################################################################*)

(** Here is some dirty work about empty set *)
Lemma lim_ch_em_ex_em (qs : QvarScope) (ch : chain qs) :
    (lim→∞ (ch)) = ∅ -> exists i, ch _[i] = ∅.
Proof.
    (** This is not true. *)
Abort.

Lemma lim_ch_em_deSemN_point_em (qs : QvarScope) (S : prog qs) (ch : chain 𝒟(qs)⁻) n:
    (lim→∞ (ch)) = ∅ -> (lim→∞ (deSemN_point_map_chain S ch n)) = ∅.
Admitted.

Lemma lim_ch_em_deSemN_em (qs : QvarScope) (S : prog qs) (ch : chain 𝒟(qs)⁻) n:
    (lim→∞ (ch)) = ∅ -> (lim→∞ (deSemN_chain S ch n)) = ∅.
Proof.
    move => Hem.
    rewrite deSem_chain_decompose. rewrite -bigU_continuous.
    rewrite lim_ch_em_deSemN_point_em //. by apply big_union_em.
Qed.

Lemma lim_ch_nem_chi_nem (qs : QvarScope) (ch : chain 𝒟( qs )⁻) i :
    (lim→∞ (ch)) <> ∅ -> ch _[i] <> ∅.
Proof.
    move => Hch. have Htemp := (@chain_limit_ub _ ch i).
    move => Heq. apply /Hch /subset_emP. rewrite -Heq. apply Htemp.
Qed.

Theorem deSem0_continuous (qs : QvarScope) (S : prog qs) (ch : chain 𝒟(qs)⁻):
    ⟦ S, 0 ⟧ (lim→∞ (ch)) = lim→∞ (deSemN_chain S ch 0).
Proof.
    case (em_classic (lim→∞ (ch))).
    move => H. rewrite H deSem0_em. rewrite lim_ch_em_deSemN_em //.
    move => H. rewrite deSem0_nem //. apply poset_antisym => //.
    apply chain_limit_lub => i.
    rewrite /deSemN_chain /deSemN_chain_obj {1}/chain_obj.
    rewrite deSem0_nem //. by apply lim_ch_nem_chi_nem.
Qed.

Theorem deSemN_point_continuous
    (qs : QvarScope) (S : prog qs) (ch : chain 𝒟(qs)⁻) n:
    ⦗ S, n ⦘ [<] (lim→∞ (ch)) = lim→∞ (deSemN_point_map_chain S ch n).
Proof.
    apply fmap_continuous.
Qed.

(** TODO #8 *)
Theorem deSemN_continuous (qs : QvarScope) (S : prog qs) (ch : chain 𝒟(qs)⁻) n:
        ⟦ S, n ⟧ (lim→∞ (ch)) = lim→∞ (deSemN_chain S ch n).
Proof.
    rewrite /deSemN /fun_comp.
    rewrite deSemN_point_continuous bigU_continuous.
    by rewrite deSem_chain_decompose.
Qed.

*)
End QParallelProg.