From iris.proofmode Require Import tactics.
From Perennial.program_logic Require Export crash_weakestpre staged_invariant_alt.
Set Default Proof Using "Type".
Import uPred.

Section modality.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.

Definition wpc_nval E (P : iProp Σ) : iProp Σ :=
  (∀ E' e s Φ Φc,
    ⌜ to_val e = None ⌝ →
    ⌜ E ⊆ E' ⌝ →
    (WPC e @ s; E' {{ λ v, P -∗ Φ v }} {{ Φc }}) -∗
    WPC e @ s; E' {{ λ v, Φ v }} {{ Φc }}).

Lemma wpc_nval_strong_mono E P P' :
  wpc_nval E P -∗
  ▷ (P -∗ |NC={E}=> P') -∗
  wpc_nval E P'.
Proof.
  iIntros "Hwpc_nval Hwand".
  rewrite /wpc_nval. iIntros (????? Hnval Hsub) "H".
  iApply wpc_ncfupd.
  iApply "Hwpc_nval"; auto.
  iApply (wpc_step_strong_mono with "[$]"); eauto.
  iSplit; last eauto.
  iNext. iIntros (?) "HP'". iModIntro. iIntros "HP".
  iApply (ncfupd_mask_mono E); auto.
  iMod ("Hwand" with "[$]"). iDestruct ("HP'" with "[$]") as "$".
  eauto.
Qed.

Lemma wpc_nval_True E : ⊢ wpc_nval E True%I.
Proof.
  rewrite /wpc_nval. iIntros (?????) "Hnval Hsub H".
  iApply (wpc_strong_mono with "H"); eauto.
  iSplit; last eauto.
  iIntros (?) "H". iApply "H". eauto.
Qed.

Lemma wpc_nval_intro E P :
  ▷ P -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  iPoseProof (wpc_nval_True) as "Htrue".
  iApply (wpc_nval_strong_mono with "Htrue"); eauto.
Qed.

Lemma wpc_nval_ncfupd E P :
  wpc_nval E (|NC={E}=> P) -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  iApply (wpc_nval_strong_mono with "HP"); eauto.
Qed.

Lemma ncfupd_wpc_nval E P :
  (|NC={E}=> wpc_nval E P) -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  rewrite /wpc_nval. iIntros (????? Hnval Hsub) "H".
  rewrite ?wpc_unfold. iIntros (mj).
  rewrite /wpc_pre.
  rewrite Hnval.
  iSplit; last first.
  { iDestruct ("H" $! _) as "(_&H)". eauto. }
  iIntros. rewrite ncfupd_eq.
  iSpecialize ("HP" with "[$]").
  iMod (fupd_mask_mono with "HP") as "(HP&HNC)"; auto.
  iSpecialize ("HP" $! E' e s Φ Φc with "[//] [//]").
  rewrite ?wpc_unfold.
  rewrite /wpc_pre.
  rewrite Hnval.
  iSpecialize ("HP" with "H").
  iDestruct ("HP" $! mj) as "(H&_)".
  iApply ("H" with "[$] [$] [$] [$]").
Qed.

Lemma wpc_nval_elim E1 E2 P e s Φ Φc :
  to_val e = None →
  E1 ⊆ E2 →
  wpc_nval E1 P -∗
  (WPC e @ s; E2 {{ λ v, P -∗ Φ v }} {{ Φc }}) -∗
  WPC e @ s; E2 {{ λ v, Φ v }} {{ Φc }}.
Proof.
  iIntros (Hnval Hsub) "Hwpc_nval Hwpc".
  iApply "Hwpc_nval"; eauto.
Qed.

Lemma wpc_nval_elim_wp E1 E2 P e s Φ :
  to_val e = None →
  E1 ⊆ E2 →
  wpc_nval E1 P -∗
  (WP e @ s; E2 {{ λ v, P -∗ Φ v }}) -∗
  WP e @ s; E2 {{ λ v, Φ v }}.
Proof.
  iIntros (Hnval Hsub) "Hwpc_nval Hwpc".
  rewrite wp_eq /wp_def.
  iApply (wpc_nval_elim with "[$]"); eauto.
Qed.

End modality.


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.
Require Export StlcFix.SpecSyntax.

#[export]
#[refine] Instance vrTm : Vr Tm := {| vr := var |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module TmKit <: Kit.

  Definition TM := Tm.
  Definition inst_vr := vrTm.

  Section Application.

    Context {Y: Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y Tm}.

    #[export]
    #[refine] Instance inst_ap : Ap Tm Y := {| ap := apTm |}.
    Proof. induction x; crush. Defined.

    #[export]
    #[refine] Instance inst_ap_vr : LemApVr Tm Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj Tm Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z Tm}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z Tm} :
    LemApComp Tm Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm} :
    LemApLiftSub Tm Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (t: Tm) :
    ∀ (ξ: Sub Ix) (ζ: Sub Tm), t[ξ][ζ] = t[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction t; crush. Qed.

End TmKit.

Module InstTm := Inst TmKit.
Export InstTm. (* Export for shorter names. *)

#[export]
Instance wsVrTm: WsVr Tm.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section Application.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y Tm}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y Tm}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApTm : WsAp Tm Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ.
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsTm ?δ ?t =>
              change (wsTm δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
      + apply IHwt2; inversion 1; crush.
      + apply IHwt3; inversion 1; crush.
  Qed.
End Application.

#[export]
Instance wsWkTm: WsWk Tm.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.
(*   - admit. *)
(*     (* induction x; cbn in H; inversion H. *) *)
(*     (* + change (wk i) with (S i) in *. *) *)
(*     (*   inversion H1; subst. eapply WsVar; eassumption. *) *)
(*     (* +  *) *)
(* Admitted. *)


From Undecidability.L Require Import Tactics.LTactics Datatypes.LNat Functions.EqBool Datatypes.LTerm.
Require Import Nat .
Import EqBool.

(* ** Extracted substitution on terms *)
Instance term_substT :
  computableTime' subst (fun s _ => (5, (fun n _ => (1, (fun t _ => ( (size s) * (size s + c__eqbComp nat * 4 + 20), tt)))))).
Proof.
  extract. unfold eqbTime.
  recRel_prettify2. all:unfold eqbTime; cbn [fst snd size].
  all:try rewrite !size_nat_enc.
  all: unfold c__natsizeS, c__natsizeO in *.
  all:try nia.
Qed.


From ITree Require Export ITree Subevent.

From ITree Require Export
     ITree
     ITreeFacts
     Events.MapDefault
     Events.State
     Events.StateFacts
     EqAxiom
.

Export SumNotations.
Export ITreeNotations.
Export Monads.
Export MonadNotation.
Export CatNotations.
Open Scope cat_scope.
Open Scope monad_scope.
Open Scope itree_scope.

Require Import String.
Require Import ZArith.

From sflib Require Import sflib.

From PromisingLib Require Import Basic.

From PromisingLib Require Import Event.
Require Export ITreeLib.

Require Import ITreeLang.

Set Implicit Arguments.

(* ========================================================================== *)
(** ** Notations *)

Module ITreeLangNotations.

  Declare Scope expr_scope.
  Bind Scope expr_scope with Inst.expr.

  Notation "! a" :=
    (Inst.expr_op1 Op1.not a) (at level 30) : expr_scope.

  Notation "a ? b" :=
    (Inst.expr_op2 Op2.eq a b) (at level 30) : expr_scope.

  Infix "+" := (Inst.expr_op2 Op2.add) : expr_scope.
  Infix "-" := (Inst.expr_op2 Op2.sub) : expr_scope.
  Infix "*" := (Inst.expr_op2 Op2.mul) : expr_scope.

  Declare Scope inst_scope.
  Bind Scope inst_scope with Inst.t.

  Notation "'skip#'" :=
    (Inst.skip) (at level 100): inst_scope.

  Notation "x '=#' e" :=
    (Inst.assign x e) (at level 60, e at level 50): inst_scope.

  Notation "'return#' e" :=
    (Inst.assign ret_reg e) (at level 60, e at level 50): inst_scope.

  Notation "x '=#*' l o" :=
    (Inst.load x l o) (at level 60, l at level 9): inst_scope.

  Notation "l '*=#' v o" :=
    (Inst.store l v o) (at level 60, v at level 9): inst_scope.

  Notation "x '=#faa' l c or ow" :=
    (Inst.update x l (MemE.fetch_add c) or ow)
      (at level 60, l at level 9, or at level 9): inst_scope.

  Notation "x '=#cas' l c1 c2 or ow" :=
    (Inst.update x l (MemE.cas c1 c2) or ow)
      (at level 60, l at level 9, or at level 9): inst_scope.

  Notation "'fence#' or ow" :=
    (Inst.fence or ow) (at level 60): inst_scope.

  Notation "x =@ args" :=
    (Inst.syscall x args) (at level 60): inst_scope.

  Notation "'abort#'" :=
    (Inst.abort) (at level 60): inst_scope.

  Declare Scope stmt_scope.
  Bind Scope stmt_scope with stmt.

  Notation "'if#' i 'then#' t 'else#' e 'fi#'" :=
    (ite i t e)
      (at level 100,
       right associativity,
       format
         "'[v ' 'if#'  i '/' '[' 'then#'  t  ']' '/' '[' 'else#'  e ']' '/' 'fi#' ']'").

  Notation "'while#' c 'do#' b 'end#'" :=
    (while c b)
      (at level 100,
       right associativity,
       format
         "'[v ' 'while#' c 'do#' '/' '[' b ']' '/' 'end#' ']'").

  Declare Scope block_scope.
  Bind Scope block_scope with block.

  Notation "{ }" := nil (format "{ }") : block_scope.
  Notation "{ x ; }" := (cons x nil) : block_scope.
  Notation "{ x ; y ; .. ; z }" := (cons x (cons y .. (cons z nil) ..)) : block_scope.

End ITreeLangNotations.

Import ITreeLangNotations.
Require Import BinNums.

(* ========================================================================== *)
(** ** Example *)
Section Example.

  Local Open Scope expr_scope.
  Local Open Scope inst_scope.
  Local Open Scope stmt_scope.
  Local Open Scope block_scope.

  Let n : Ident.t := xH.
  Let out : Ident.t := xO xH.

  Definition factorial : block :=
    { n =# (10%Z: Const.t);
      out =# (1%Z: Const.t);
      while# (! (n ? (0%Z: Const.t))) do#
      { if# (! (n ? (1%Z: Const.t)))
        then#
        { out =# n * out;
          n =# n - (1%Z: Const.t) }
        else#
        { n =# (0%Z: Const.t); }
        fi#;
      }
      end#;
      skip#;
      return# out
    }
  .

End Example.


From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.
From bisimulations Require Import paths.
From bisimulations Require Import nonreflexive.semibranching.
From bisimulations Require Import reflexive.branching.

Section NonreflVsRefl.
Context `{System : system X}.

Notation nr_sb_apart := (@nonreflexive.semibranching.sb_apart X System).
Notation r_b_apart := (@reflexive.branching.b_apart X WithRefl).

Theorem nonrefl_to_refl : ∀ p q, nr_sb_apart p q → r_b_apart p q.
Proof. eapply nonreflexive.semibranching.sb_apart_strong_ind'; [eauto with hints|..].
  - intros p1 p2 q1 Hp12 Ha_p2_q1 HQ.
    eapply reflexive.branching.b_apart_step; [by eapply WithRefl_can_step|].
    intros q2 Hq12 q3 Hq23.
    rewrite <- WithRefl_rtc_can_step in Hq12.
    destruct Hq23 as [Hq23|[_ <-]].
    { by destruct (HQ q2 Hq12 q3 Hq23) as [[]|]; [left|right]. }
    eapply rtc_inv_r in Hq12 as [<-|(qm & Hq1m & Hqm2)].
    { by right. }
    by destruct (HQ qm Hq1m q2 Hqm2) as [[]|]; [left|right].
  - intros p1 p2 q1 Hp12 HQ.
    eapply reflexive.branching.b_apart_step; [by eapply WithRefl_can_step|].
    intros q2 Hq12 q3 Hq23.
    rewrite <- WithRefl_rtc_can_step in Hq12.
    rewrite <- WithRefl_can_step_loud in Hq23.
    by destruct (HQ q2 Hq12 q3 Hq23); [left|right].
Qed.

Theorem refl_to_nonrefl : ∀ p q, r_b_apart p q → nr_sb_apart p q.
Proof. eapply reflexive.branching.b_apart_strong_ind'; [eauto with hints|intros [] p1 p2 q1 Hp12 HQ].
  - assert (rtc (@can_step X WithRefl silent) q1 q1) as Hq11 by eauto with steps.
    assert (@can_step X WithRefl silent q1 q1) as Hq11' by by right.
    destruct (HQ q1 Hq11 q1 Hq11'); try done.
    destruct Hp12 as [Hp12|[_ <-]]; [|done].
    eapply sb_apart_silent; try done.
    intros q2 Hq12 q3 Hq23.
    rewrite WithRefl_rtc_can_step in Hq12.
    eapply WithRefl_can_step in Hq23.
    assert (rtc (@can_step X WithRefl silent) q1 q3) as Hq13 by eauto with steps.
    assert (@can_step X WithRefl silent q3 q3) as Hq33' by by right.
    destruct (HQ q3 Hq13 q3 Hq33') as [|]; [|by right].
    destruct (HQ q2 Hq12 q3 Hq23) as [|]; [left|right]; eauto with hints.
  - eapply WithRefl_can_step_loud in Hp12.
    eapply sb_apart_loud; try done.
    intros q2 Hq12 q3 Hq23.
    rewrite WithRefl_rtc_can_step in Hq12.
    eapply WithRefl_can_step_loud in Hq23.
    by destruct (HQ q2 Hq12 q3 Hq23) as [|]; [left|right].
Qed.

End NonreflVsRefl.


(**************************************************************************
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibReflect.

(* ********************************************************************** *)
(** * Unit type *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

(** From the Prelude.

  Inductive unit : Type :=
    | tt : unit.

  Add Printing If bool.
  Delimit Scope bool_scope with bool.

*)

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance Inhab_unit : Inhab unit.
Proof using. intros. apply (Inhab_of_val tt). Qed.

(* ********************************************************************** *)
(** * Properties *)

(* ---------------------------------------------------------------------- *)
(** ** Uniqueness *)

Lemma unit_eq : forall (tt1 tt2 : unit),
  tt1 = tt2.
Proof using. intros. destruct tt1. destruct~ tt2. Qed.


From iris.proofmode Require Import base proofmode classes.
From iris.base_logic.lib Require Export fancy_updates.
From iris.algebra Require Import excl.
From iris.bi Require Export weakestpre fixpoint big_op.
From iris.prelude Require Import options.
From iris.base_logic.lib Require Export ghost_map invariants.

From self.prelude Require Import stdpp_ext iris_ext.
From self.program_logic Require Export exec weakestpre.
From self.prob_lang Require Import
  primitive_laws class_instances spec_ra tactics notation erasure
  metatheory lang.
From self.prob Require Export couplings distribution.
Import uPred.

Section adequacy.
  Context `{!prelocGS Σ}.

  Lemma refRcoupl_dbind' `{Countable A, Countable A', Countable B, Countable B'}
    (f : A → distr A') (g : B → distr B') (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (T : A' → B' → Prop) n :
    ⌜refRcoupl μ1 μ2 R⌝ -∗
    (∀ a b, ⌜R a b⌝ ={∅}▷=∗^(S n) ⌜refRcoupl (f a) (g b) T⌝) -∗
    |={∅}▷=>^(S n) ⌜refRcoupl (dbind f μ1) (dbind g μ2) T⌝ : iProp Σ.
  Proof.
    iIntros (HR) "H".
    iApply (step_fupdN_mono _ _ _ (⌜(∀ a b, R a b → refRcoupl (f a) (g b) T)⌝)).
    { iIntros (?). iPureIntro. by eapply refRcoupl_dbind. }
    iIntros (???) "/=".
    iMod ("H" with "[//]"); auto.
  Qed.

  Lemma exec_coupl_erasure (e1 : expr) (σ1 : state) (e1' : expr) (σ1' : state) (n : nat) φ :
    to_val e1 = None →
    exec_coupl e1 σ1 e1' σ1' (λ '(e2, σ2) '(e2', σ2'),
        |={∅}▷=>^(S n) ⌜refRcoupl (exec_val n (e2, σ2)) (lim_exec_val (e2', σ2')) φ⌝)
    ⊢ |={∅}▷=>^(S n) ⌜refRcoupl (exec_val (S n) (e1, σ1)) (lim_exec_val (e1', σ1')) φ⌝.
  Proof.
    iIntros (Hv) "Hexec".
    iAssert (⌜to_val e1 = None⌝)%I as "-#H"; [done|]. iRevert "Hexec H".
    rewrite /exec_coupl /exec_coupl'.
    set (Φ := (λ '((e1, σ1), (e1', σ1')),
                (⌜to_val e1 = None⌝ ={∅}▷=∗^(S n)
                 ⌜refRcoupl (exec_val (S n) (e1, σ1))
                            (lim_exec_val (e1', σ1')) φ⌝)%I) :
           prodO cfgO cfgO → iPropI Σ).
    assert (NonExpansive Φ).
    { intros m ((?&?)&(?&?)) ((?&?)&(?&?)) [[[=] [=]] [[=] [=]]]. by simplify_eq. }
    set (F := (exec_coupl_pre (λ '(e2, σ2) '(e2', σ2'),
                   |={∅}▷=>^(S n) ⌜refRcoupl (exec_val n (e2, σ2))
                     (lim_exec_val (e2', σ2')) φ⌝)%I)).
    iPoseProof (least_fixpoint_iter F Φ with "[]") as "H"; last first.
    { iIntros "Hfix %". by iMod ("H" $! ((_, _), (_, _)) with "Hfix [//]"). }
    clear.
    iIntros "!#" ([[e1 σ1] [e1' σ1']]). rewrite /exec_coupl_pre.
    iIntros "[(%R & % & %Hcpl & H) | [(%R & % & %Hcpl & H) | [(%R & %m & %Hcpl & H) | [H | [H | H]]]]] %Hv".
    - rewrite exec_val_Sn_not_val; [|done].
      rewrite lim_exec_val_prim_step.
      destruct (to_val e1') eqn:Hv'.
      + destruct (decide (prim_step e1 σ1 = dzero)) as [Hs|].
        * rewrite /= Hs dbind_dzero.
          do 3 iModIntro. iApply step_fupdN_intro; [done|].
          iModIntro. iPureIntro.
          apply refRcoupl_dzero.
        * assert (prim_step e1' σ1' = dzero) as Hz by by apply val_stuck_dzero.
          rewrite /= (val_stuck_dzero e1') in Hcpl; [|eauto].
          by apply Rcoupl_dzero_r_inv in Hcpl.
      + rewrite prim_step_or_val_no_val; [|done].
        iApply (refRcoupl_dbind' _ _ _ _ R).
        { iPureIntro. by apply Rcoupl_refRcoupl. }
        iIntros ([] [] HR). by iMod ("H" with "[//]").
    - rewrite exec_val_Sn_not_val; [|done].
      rewrite -(dret_id_left (lim_exec_val)).
      iApply refRcoupl_dbind'.
      { iPureIntro. apply Rcoupl_pos_R in Hcpl. by apply Rcoupl_refRcoupl. }
      iIntros ([] [] (?&?& [= -> ->]%dret_pos)).
      by iMod ("H"  with "[//]").
    - rewrite -(dret_id_left (exec_val _)).
      rewrite (lim_exec_val_exec m).
      iApply refRcoupl_dbind'.
      { iPureIntro. apply Rcoupl_pos_R in Hcpl. by apply Rcoupl_refRcoupl. }
      iIntros ([] [] (?& [= -> ->]%dret_pos &?)).
      by iMod ("H"  with "[//] [//]").
    - iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (exec_val (S n) (e1, σ1))
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i α Hα%elem_of_list_lookup_2) "(% & % & %Hcpl & H)".
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ e2 σ2 σ2', R2 (e2, σ2) σ2' → refRcoupl (exec_val n (e2, σ2))
                                                             (lim_exec_val (e1', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα.
          apply elem_of_elements, elem_of_dom in Hα as [].
          eapply refRcoupl_erasure_r; eauto.
        - iIntros (????). by iMod ("H" with "[//]"). }
      iInduction (language.get_active σ1') as [| α'] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
    - iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (exec_val (S n) (e1, σ1))
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i α' Hα'%elem_of_list_lookup_2) "(% & %Hcpl & H)".
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ σ2 e2' σ2', R2 σ2 (e2', σ2') → refRcoupl (exec_val (S n) (e1, σ2))
                                                               (lim_exec_val (e2', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα'.
          apply elem_of_elements, elem_of_dom in Hα' as [].
          eapply refRcoupl_erasure_l; eauto.
        - iIntros (????). by iMod ("H" with "[//] [//]"). }
      iInduction (language.get_active σ1) as [| α'] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
    - rewrite exec_val_Sn_not_val; [|done].
      iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (prim_step e1 σ1 ≫= exec_val n)
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i [α1 α2] [Hα1 Hα2]%elem_of_list_lookup_2%elem_of_list_prod_1) "(% & %Hcpl & H)".
        rewrite -exec_val_Sn_not_val; [|done].
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ σ2 σ2', R2 σ2 σ2' → refRcoupl (exec_val (S n) (e1, σ2))
                                                    (lim_exec_val (e1', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα1, Hα2.
          apply elem_of_elements, elem_of_dom in Hα1 as [], Hα2 as [].
          eapply refRcoupl_erasure; eauto.
        - iIntros (???). by iMod ("H" with "[//] [//]"). }
      iInduction (list_prod (language.get_active σ1) (language.get_active σ1'))
        as [| [α α']] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
  Qed.

  Theorem wp_refRcoupl_step_fupdN (e e' : expr) (σ σ' : state) n φ :
    state_interp σ ∗ spec_interp (e', σ') ∗ spec_ctx ∗ WP e {{ v, ∃ v', ⤇ Val v' ∗ ⌜φ v v'⌝ }} ⊢
    |={⊤,∅}=> |={∅}▷=>^n ⌜refRcoupl (exec_val n (e, σ)) (lim_exec_val (e', σ')) φ⌝.
  Proof.
    iInduction n as [|n] "IH" forall (e σ e' σ'); iIntros "([Hh Ht] & HspecI_auth & #Hctx & Hwp)".
    - rewrite /exec_val /=.
      destruct (to_val e) eqn:Heq.
      + apply of_to_val in Heq as <-.
        rewrite wp_value_fupd.
        iMod "Hwp" as (v') "[Hspec_frag %]".
        iInv specN as (ρ e0 σ0 n) ">(HspecI_frag & %Hexec & Hspec_auth & Hstate)" "_".
        iDestruct (spec_interp_auth_frag_agree with "HspecI_auth HspecI_frag") as %<-.
        iDestruct (spec_prog_auth_frag_agree with "Hspec_auth Hspec_frag") as %->.
        iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        erewrite lim_exec_val_exec_det; [|done].
        iPureIntro.
        rewrite /dmap.
        by apply refRcoupl_dret.
      + iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        iPureIntro.
        apply refRcoupl_dzero.
    - rewrite exec_val_Sn /prim_step_or_val /=.
      destruct (to_val e) eqn:Heq.
      + apply of_to_val in Heq as <-.
        rewrite wp_value_fupd.
        iMod "Hwp" as (v') "[Hspec_frag %]".
        iInv specN as (ξ ρ e0 σ0) ">(HspecI_frag & %Hexec & Hspec_auth & Hstate)" "_".
        iDestruct (spec_interp_auth_frag_agree with "HspecI_auth HspecI_frag") as %<-.
        iDestruct (spec_prog_auth_frag_agree with "Hspec_auth Hspec_frag") as %->.
        iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        iApply step_fupdN_intro; [done|]. do 4 iModIntro.
        iPureIntro.
        rewrite exec_val_unfold dret_id_left /=.
        erewrite lim_exec_val_exec_det; [|done].
        by apply refRcoupl_dret.
      + rewrite wp_unfold /wp_pre /= Heq.
        iMod ("Hwp" with "[$]") as "Hcpl".
        iModIntro.
        iPoseProof
          (exec_coupl_mono _ (λ '(e2, σ2) '(e2', σ2'), |={∅}▷=>^(S n)
             ⌜refRcoupl (exec_val n (e2, σ2)) (lim_exec_val (e2', σ2')) φ⌝)%I
            with "[] Hcpl") as "H".
        { iIntros ([] []) "H !> !>".
          iMod "H" as "(Hstate & HspecI_auth & Hwp)".
          iMod ("IH" with "[$]") as "H".
          iModIntro. done. }
        rewrite -exec_val_Sn_not_val; [|done].
        by iApply (exec_coupl_erasure with "H").
  Qed.

End adequacy.

Class prelocGpreS Σ := PrelocGpreS {
  prelocGpreS_iris  :> invGpreS Σ;
  prelocGpreS_heap  :> ghost_mapG Σ loc val;
  prelocGpreS_tapes :> ghost_mapG Σ loc (list bool);
  prelocGpreS_cfg   :> inG Σ (authUR cfgUR);
  prelocGpreS_prog  :> inG Σ (authR progUR);
}.

Definition prelocΣ : gFunctors :=
  #[invΣ; ghost_mapΣ loc val; ghost_mapΣ loc (list bool);
    GFunctor (authUR cfgUR); GFunctor (authUR progUR)].
Global Instance subG_prelocGPreS {Σ} : subG prelocΣ Σ → prelocGpreS Σ.
Proof. solve_inG. Qed.

Theorem wp_refRcoupl Σ `{prelocGpreS Σ} (e e' : expr) (σ σ' : state) n φ :
  (∀ `{prelocGS Σ}, ⊢ spec_ctx -∗ ⤇ e' -∗ WP e {{ v, ∃ v', ⤇ Val v' ∗ ⌜φ v v'⌝ }}) →
  refRcoupl (exec_val n (e, σ)) (lim_exec_val (e', σ')) φ.
Proof.
  intros Hwp.
  eapply (step_fupdN_soundness_no_lc _ n 0).
  iIntros (Hinv) "_".
  iMod (ghost_map_alloc σ.(heap)) as "[%γH [Hh _]]".
  iMod (ghost_map_alloc σ.(tapes)) as "[%γT [Ht _]]".
  iMod (ghost_map_alloc σ'.(heap)) as "[%γHs [Hh_spec _]]".
  iMod (ghost_map_alloc σ'.(tapes)) as "[%γTs [Ht_spec _]]".
  iMod (own_alloc ((● (Excl' (e', σ'))) ⋅ (◯ (Excl' (e', σ'))))) as "(%γsi & Hsi_auth & Hsi_frag)".
  { by apply auth_both_valid_discrete. }
  iMod (own_alloc ((● (Excl' e')) ⋅ (◯ (Excl' e')))) as "(%γp & Hprog_auth & Hprog_frag)".
  { by apply auth_both_valid_discrete. }
  set (HspecGS := CfgSG Σ _ γsi _ γp _ _ γHs γTs).
  set (HprelocGS := HeapG Σ _ _ _ γH γT HspecGS).
  iMod (inv_alloc specN ⊤ spec_inv with "[Hsi_frag Hprog_auth Hh_spec Ht_spec]") as "#Hctx".
  { iModIntro. iExists _, _, _, O. iFrame. rewrite exec_O dret_1_1 //. }
  iApply wp_refRcoupl_step_fupdN.
  iFrame. iFrame "Hctx".
  by iApply (Hwp with "[Hctx] [Hprog_frag]").
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 PendingCheckAux.Spec.
Require Import RVIC4.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition check_pending_ptimers_spec0 (rec: Pointer) (adt: RData) : option RData :=
    match rec with
    | (_rec_base, _rec_ofst) =>
      when'' _g_rec_base, _g_rec_ofst == get_rec_g_rec_spec (_rec_base, _rec_ofst) adt;
      rely is_int _g_rec_ofst;
      when' _cntp_ctl == sysreg_read_spec 32 adt;
      rely is_int64 _cntp_ctl;
      when'' _t'6_base, _t'6_ofst == get_rec_ptimer_spec (_rec_base, _rec_ofst) adt;
      rely is_int _t'6_ofst;
      when _t'7, adt == check_timer_became_asserted_spec (_t'6_base, _t'6_ofst) (VZ64 _cntp_ctl) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        when adt == granule_lock_spec (_g_rec_base, _g_rec_ofst) adt;
        rely is_int64 (Z.lor _cntp_ctl 2);
        let _cntp_ctl := (Z.lor _cntp_ctl 2) in
        when adt == sysreg_write_spec 32 (VZ64 _cntp_ctl) adt;
        when' _t'3 == get_rec_sysregs_spec (_rec_base, _rec_ofst) 69 adt;
        rely is_int64 _t'3;
        rely is_int64 (Z.land _t'3 18446744073709549567);
        when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 69 (VZ64 (Z.land _t'3 18446744073709549567)) adt;
        when' _t'4 == get_rec_sysregs_spec (_rec_base, _rec_ofst) 69 adt;
        rely is_int64 _t'4;
        when adt == sysreg_write_spec 69 (VZ64 _t'4) adt;
        when adt == set_rec_ptimer_asserted_spec (_rec_base, _rec_ofst) 1 adt;
        when'' _t'5_base, _t'5_ofst == get_rec_rvic_spec (_rec_base, _rec_ofst) adt;
        rely is_int _t'5_ofst;
        when adt == rvic_set_pending_spec (_t'5_base, _t'5_ofst) (VZ64 30) adt;
        when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
        Some adt
      else
        Some adt
     end
    .

End SpecLow.


Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Open Scope tprop_scope.

Require Import Glib.Glib.

Ltac tentails :=
  match goal with
  | |- ?R @?s ⊨ ⟦?P⟧   => change (P s)
  | |- ?R @?s ⊭ ⟦?P⟧   => change (~ P s)
  | |- ?R @?s ⊨ !⟦?P⟧ => change (~ P s)
  end.

Tactic Notation "tentails!" :=
  cbn;
  repeat match goal with
  | |- ?R @?s ⊨ ?P => unfold P
  | |- ?R @?s ⊭ ?P => unfold P
  | |- ?R @?s ⊨ ! ?P => unfold P
  end;
  tentails;
  cbn.

Tactic Notation "tentails" "in" hyp(H) :=
  change (?R @?s ⊨ ⟦?P⟧)   with (P s) in H +
  change (?R @?s ⊭ ⟦?P⟧)   with (~ P s) in H +
  change (?R @?s ⊨ !⟦?P⟧) with (~ P s) in H.

Tactic Notation "tentails!" "in" hyp(H) :=
  cbn in H;
  repeat match type of H with
  | ?R @?s ⊨ ?P => unfold P in H
  | ?R @?s ⊭ ?P => unfold P in H
  | ?R @?s ⊨ ! ?P => unfold P in H
  end;
  progress tentails in H;
  cbn in H.

Tactic Notation "tentails" "in" "*" :=
  try tentails;
  repeat find (fun H => tentails in H).

Tactic Notation "tentails!" "in" "*" :=
  try tentails!;
  repeat find (fun H => tentails! in H).

Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⇾ ?q) with (R @s ⊨ p -> R @s ⊨ q) +
  rewrite rew_timpl +
  setoid_rewrite rew_timpl.
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⇾ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H +
  rewrite rew_timpl in H +
  setoid_rewrite rew_timpl in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ !?P) with (R @s ⊭ P) +
  rewrite rew_tnot +
  setoid_rewrite rew_tnot.
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ !?P) with (R @s ⊭ P) in H +
  rewrite rew_tnot in H +
  setoid_rewrite rew_tnot in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P && ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) +
  rewrite rew_tconj +
  setoid_rewrite rew_tconj.
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P && ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H +
  rewrite rew_tconj in H +
  setoid_rewrite rew_tconj in H.

Tactic Notation "unfold_tdisj" :=
  progress change_no_check (?R @?s ⊨ ?P || ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) +
  rewrite rew_tdisj +
  setoid_rewrite rew_tdisj.
Tactic Notation "unfold_tdisj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P || ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) in H +
  rewrite rew_tdisj in H +
  setoid_rewrite rew_tdisj in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⇿ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) +
  rewrite rew_tbiimpl +
  setoid_rewrite rew_tbiimpl.
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⇿ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H +
  rewrite rew_tbiimpl in H +
  setoid_rewrite rew_tbiimpl in H.

Tactic Notation "unfold_tlift" :=
  progress change_no_check (?R @?s ⊨ ⟦?P⟧) with (P s) +
  rewrite rew_tlift +
  setoid_rewrite rew_tlift.
Tactic Notation "unfold_tlift" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ⟦?P⟧) with (P s) in H +
  rewrite rew_tlift in H +
  setoid_rewrite rew_tlift in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) +
  rewrite rew_AX +
  setoid_rewrite rew_AX.
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H +
  rewrite rew_AX in H +
  setoid_rewrite rew_AX in H.

Tactic Notation "unfold_EX" :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) +
  rewrite rew_EX +
  setoid_rewrite rew_EX.
Tactic Notation "unfold_EX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) in H +
  rewrite rew_EX in H +
  setoid_rewrite rew_EX in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_AG +
  setoid_rewrite rew_AG.
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_AG in H +
  setoid_rewrite rew_AG in H.

Tactic Notation "unfold_EG" :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_EG +
  setoid_rewrite rew_EG.
Tactic Notation "unfold_EG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_EG in H +
  setoid_rewrite rew_EG in H.

Tactic Notation "unfold_AF" :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_AF +
  setoid_rewrite rew_AF.
Tactic Notation "unfold_AF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_AF in H +
  setoid_rewrite rew_AF in H.

Tactic Notation "unfold_EF" :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_EF +
  setoid_rewrite rew_EF.
Tactic Notation "unfold_EF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_EF in H +
  setoid_rewrite rew_EF in H.

Tactic Notation "unfold_AU" :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_AU +
  setoid_rewrite rew_AU.
Tactic Notation "unfold_AU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_AU in H +
  setoid_rewrite rew_AU in H.

Tactic Notation "unfold_EU" :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_EU +
  setoid_rewrite rew_EU.
Tactic Notation "unfold_EU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_EU in H +
  setoid_rewrite rew_EU in H.

Tactic Notation "unfold_AW" :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall x, in_path x p -> R @x ⊨ P && !Q) \/
      (exists i,
        (forall x, in_path_before x i p -> R @x ⊨ P) /\
        R @(p i) ⊨ Q)) +
  rewrite rew_AW +
  setoid_rewrite rew_AW.
Tactic Notation "unfold_AW" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall x, in_path x p -> R @x ⊨ P && !Q) \/
      (exists i,
        (forall x, in_path_before x i p -> R @x ⊨ P) /\
        R @(p i) ⊨ Q)) in H +
  rewrite rew_AW in H +
  setoid_rewrite rew_AW in H.

(* tintro - intro a timpl *)

Tactic Notation "tintro" :=
  match goal with
  | |- _ @_ ⊨ !_ => unfold_tnot; intro
  | |- _ @_ ⊨ _ ⇾ _ => unfold_timpl; intro
  end.

Tactic Notation "tintro" ident(x) :=
  match goal with
  | |- _ @_ ⊨ !_ => unfold_tnot; intro x
  | |- _ @_ ⊨ _ ⇾ _ => unfold_timpl; intro x
  end.

Tactic Notation "tintros" :=
  repeat tintro.
Tactic Notation "tintros" ident(x1) :=
  tintro x1.
Tactic Notation "tintros" ident(x1) ident(x2) :=
  tintro x1; tintros x2.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) :=
  tintro x1; tintros x2 x3.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) :=
  tintro x1; tintros x2 x3 x4.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) :=
  tintro x1; tintros x2 x3 x4 x5.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x6) :=
  tintro x1; tintros x2 x3 x4 x5 x6.

(* tsimpl - simple a tprop *)

(* Remove AX? May go on forever *)
Tactic Notation "tsimpl_step" :=
  unfold_timpl +
  unfold_tbiimpl +
  unfold_tnot +
  unfold_AX +
  unfold_EX +
  unfold_AG +
  unfold_EG +
  unfold_AF +
  unfold_EF +
  unfold_AU +
  unfold_EU +
  unfold_AW.

Tactic Notation "tsimpl_step" "in" hyp(H) :=
  unfold_timpl in H +
  unfold_tbiimpl in H +
  unfold_tnot in H +
  unfold_AX in H +
  unfold_EX in H +
  unfold_AG in H +
  unfold_EG in H +
  unfold_AF in H +
  unfold_EF in H +
  unfold_AU in H +
  unfold_EU in H +
  unfold_AW in H.

Tactic Notation "tsimpl" := repeat tsimpl_step.
Tactic Notation "tsimpl" "in" hyp(H) := repeat tsimpl_step in H.
Tactic Notation "tsimpl" "in" "*" :=
  try tsimpl;
  repeat match goal with
  | H: _ @_ ⊨ _ |- _ => tsimpl in H
  end.

(* tapply: carefully unfolds TProp hypothesis just enough to use apply *)

Ltac _tapply_unfold_step H :=
  match type of H with
  | _ @_ ⊨ _ ⇾ _ =>
      unfold_timpl in H
  | _ @_ ⊨ !_ =>
      unfold_tnot in H
  | _ @_ ⊨ _ ⇿ _ =>
      unfold_tbiimpl in H
  | _ @_ ⊨ AX _ =>
      unfold_AX in H
  | _ @_ ⊨ AG _ =>
      unfold_AG in H
  end +
  unfold_timpl in H +
  unfold_tnot in H +
  unfold_tbiimpl in H +
  unfold_AX in H +
  unfold_AG in H.

Ltac _tapply_aux H :=
  apply H + (_tapply_unfold_step H; _tapply_aux H).

Ltac _tapply_aux_in H H2 :=
  apply H in H2 + (_tapply_unfold_step H; _tapply_aux_in H H2).

Ltac _etapply_aux H :=
  eapply H + (_tapply_unfold_step H; _etapply_aux H).

Ltac _etapply_aux_in H H2 :=
  eapply H in H2 + (_tapply_unfold_step H; _etapply_aux_in H H2).

Tactic Notation "tapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux Htemp;
  clear Htemp.

Tactic Notation "tapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux Htemp;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "tapplyc" hyp(H) :=
  tapply H; clear H.
Tactic Notation "tapplyc" hyp(H) "in" hyp(H2) :=
  tapply H in H2; clear H.
Tactic Notation "etapplyc" hyp(H) :=
  etapply H; clear H.
Tactic Notation "etapplyc" hyp(H) "in" hyp(H2) :=
  etapply H in H2; clear H.

Tactic Notation "tcut" uconstr(P) :=
  match goal with
  | |- ?R @?s ⊨ ?Q =>
      cut (R @s ⊨ P); [change (R @s ⊨ P ⇾ Q)| ]
  end.

Tactic Notation "tforward" hyp(H):=
  match type of H with
  | ?R @?s ⊨ ?P ⇾ ?Q =>
      let _temp := fresh in
      define (R @s ⊨ P) as _temp;
      [ |
        specialize (H _temp);
        unfold _temp in H;
        clear _temp
      ]
 end.

Tactic Notation "tforward" hyp(H) "by" tactic3(tac) :=
  tforward H; [solve [tac]| ].

Close Scope tprop_scope.


Require Import FiatFormal.Language.Step.
Require Import FiatFormal.Language.SubstExpExp.
Require Import FiatFormal.Language.SubstTypeExp.
Require Import FiatFormal.Language.SubstTypeType.
Require Import FiatFormal.Language.TyJudge.

Lemma In_Context :
  forall C Val x,
    exps_ctx Val C
    -> @In exp x (C x).
Proof.
  intros.
  induction H; auto.
Qed.

Lemma canonicalFormTFun :
  forall ds ke te t1 t2 x,
    TYPE ds ke te x (TFun t1 t2)
    -> value x
    -> exists x', x = (XFix t1 t2 x').
Proof.
  intros. gen ds ke te t1 t2 H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists x; reflexivity.
Qed.

Lemma canonicalFormTNFun :
  forall ds ke te tsArgs tRes x,
    TYPE ds ke te x (TNFun tsArgs tRes)
    -> value x
    -> exists x', x = (XNFun tsArgs x').
Proof.
  intros. gen ds ke te tsArgs tRes H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists x; reflexivity.
Qed.

Lemma canonicalFormTNProd :
  forall ds ke te ts x,
    TYPE ds ke te x (TNProd ts)
    -> value x
    -> exists xs, x = (XTup xs).
Proof.
  intros. gen ds ke te ts H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists (@nil exp); reflexivity.
  exists (l0 :> x); reflexivity.
Qed.

Lemma wellTypedProjHasX :
  forall ds ke te ts t xs n,
    TYPE ds ke te (XTup xs) (TNProd ts)
    -> get n ts = Some t
    -> exists x, get n xs = Some x.
Proof.
  intros.
  inverts H.
  pose proof @get_length_less_exists exp.
  pose proof(Forall2_length _ _ _ H5).
  apply get_length_less in H0. rewrite <- H1 in H0.
  spec H H0. dest x. eauto.
Qed.

(* A well typed expression is either a value, can take a step,
   or contains a choice. *)
Theorem progress
  : forall pb ds pbOK x,
    (exists t, TYPE ds nil nil x t)
    -> value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x.
Proof.
 intros. gen pb ds pbOK.
 induction x using exp_mutind with
     (PA := fun a => a = a);
   rip; first [destruct H as [tx] | destruct H0 as [tx]];
     try invert_exp_type; nope.

 Case "XApp".
 right.
 edestruct IHx1; eauto.
 SCase "value x1".
 edestruct IHx2; eauto.
 SSCase "value x2".
 pose proof (canonicalFormTFun).
 spec H1 H4. spec H1 H. destruct H1 as [x' LAM]; subst.
 SSSCase "fix".
 left; exists (substXX 0 (XFix t11 tx x') (substXX 0 x2 x')). apply EsFixApp. inverts H0; auto.
 destruct H0 as [STx2 | HCx2].
 SSCase "x2 steps".
 destruct STx2 as [x2'].
 left; exists (XApp x1 x2'). eauto.
 SSCase "x2 hasChoice".
 right; auto.
 destruct H as [STx1 | HCx1].
 SCase "x1 steps".
 destruct STx1 as [x1'].
 left; exists (XApp x1' x2).
 eapply (EsContext pb ds pbOK (fun xx => XApp xx x2)); eauto.
 SCase "x1 hasChoice".
 right; auto.

 Case "XTup".
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.
 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H2; rip.
 inverts H3; rip.
 (* All ctor args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 right.
 dest C. dest x'.
 rip. destruct H3 as [STx' | HCx'].
 left.
 lets D: step_context_XTup_exists H1 STx'.
 destruct D as [x'']. eauto.
 SCase "hasChoice x".
 (* nope. *)
 right; apply HcTup.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.

 Case "XProj".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H pbOK); eauto.
 SCase "value x".
 pose proof (canonicalFormTNProd).
 spec H1 H4. spec H1 H0. dest xs; subst.
 left.
 pose proof (wellTypedProjHasX _ _ _ _ _ _ _ H4 H6).
 dest x. exists x. apply EsTupProj; auto.
 inverts H0. inverts H2; auto.
 destruct H0 as [STx | HCx].
 SCase "x steps".
 left. dest x'. exists (XProj n x').
 eapply (EsContext pb ds pbOK (fun xx => XProj n xx)); eauto.
 SCase "x hasChoice".
 (* nope. *)
 right; auto.

 Case "XNFun".
 left; eauto.

 Case "XNApp".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H0 pbOK); eauto.
 pose proof (canonicalFormTNFun).
 spec H2 H5. spec H2 H1. dest x'; subst.
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.

 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H4; rip. inverts H6. auto.
 (* All args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 dest C. rename x' into x''. dest x'.
 rip. destruct H6 as [STx' | HCx'].
 left.
 destruct STx'.
 exists (XNApp (XNFun ts x'') (C x)).
 eapply (EsContext pb ds pbOK (fun xx => XNApp (XNFun ts x'') (C xx))).
 apply XcNApp2; eauto. auto.
 SCase "x' hasChoice".
 right; apply HcNApp2.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.
 destruct H1 as [STx | HCx].
 left.
 dest x'.
 exists (XNApp x' xs); eauto.
 eapply (EsContext pb ds pbOK (fun xx => XNApp xx xs)); eauto.
 SCase "x hasChoice".
 right; eauto.

 Case "XFix".
 left; eauto.

 Case "XCon".
 (* All ctor args are either wnf or can step *)
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.
 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H2; rip.
 inverts H6; rip.
 (* All ctor args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 right.
 dest C. dest x'.
 rip. destruct H6 as [STx' | HCx'].
 left.
 lets D: step_context_XCon_exists H1 STx'.
 destruct D as [x'']. eauto.
 SCase "hasChoice x".
 right; apply HcCon.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.

 Case "XMatch".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H0 pbOK); eauto.
 SCase "x value".
 destruct x; nope.
 SSCase "XCon".
 inverts_type.
 rewrite H8 in H11. inversion H11; subst.
 assert (exists ts x, getAlt d aa = Some (AAlt d ts x)).
 apply getAlt_exists.
 repeat nforall. spec H10 H15. auto.
 dest ts. dest x.
 left. exists (substXXs 0 l x). eapply EsMatchAlt.
 inverts H1. inverts H3; auto. eauto.
 destruct H1 as [STx | HCx].
 SCase "x steps".
 left; destruct STx as [x'].
 exists (XMatch x' aa).
 lets D: EsContext XcMatch; eauto.
 SCase "x hasChoice".
 right; auto.
Qed.


From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

From ITree Require Import
     Events.State
     CategoryOps.
Import Basics.Monads.

From CTree Require Import
     CTree
     Fold
     Eq
     Eq.Epsilon.

Import SBisimNotations.
Import MonadNotation.
Open Scope monad_scope.

Set Implicit Arguments.

#[global] Instance MonadBr_stateT {S M C} {MM : Monad M} {AM : MonadBr C M}: MonadBr C (stateT S M) :=
  fun b X c s => f <- mbr b c;; ret (s,f).

#[global] Instance MonadTrigger_stateT {E S M} {MM : Monad M} {MT: MonadTrigger E M} :
  MonadTrigger E (stateT S M) :=
  fun _ e s => v <- mtrigger e;; ret (s, v).

Definition fold_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M}
  (h : E ~> stateT S M) (g : bool -> C ~> stateT S M) :
  ctree E C ~> stateT S M := fold h g.

Definition interp_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M} {BM : MonadBr C M}
  (h : E ~> stateT S M) :
  ctree E C ~> stateT S M := interp h.

Definition refine_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M} {TM : MonadTrigger E M}
  (g : bool -> C ~> stateT S M) :
  ctree E C ~> stateT S M := refine g.

#[global] Typeclasses Opaque fold_state interp_state refine_state.

Section State.
  Variable (S : Type).
  Variant stateE : Type -> Type :=
    | Get : stateE S
    | Put : S -> stateE unit.

  Definition get {E C} `{stateE -< E} : ctree E C S := trigger Get.
  Definition put {E C} `{stateE -< E} : S -> ctree E C unit := fun s => trigger (Put s).

  Definition h_state {E C} : stateE ~> stateT S (ctree E C) :=
    fun _ e s =>
      match e with
      | Get => Ret (s, s)
      | Put s' => Ret (s', tt)
      end.

  Definition pure_state {E C} : E ~> stateT S (ctree E C)
    := fun _ e s => Vis e (fun x => Ret (s, x)).

  Definition pure_state_choice {E C} b : C ~> stateT S (ctree E C)
    := fun _ c s => br b c (fun x => Ret (s, x)).

  Definition run_state {E C} `{B1 -< C}
    : ctree (stateE +' E) C ~> stateT S (ctree E C) :=
    fold_state (case_ h_state pure_state) pure_state_choice.

End State.

Ltac break :=
  match goal with
  | v: _ * _ |- _ => destruct v
  end.

(* Stateful handlers [E ~> stateT S (itree F)] and morphisms
   [E ~> state S] define stateful itree morphisms
   [itree E ~> stateT S (itree F)]. *)
Section State.

  Variable (S : Type).
  Context {E F C D : Type -> Type}
          `{B1 -< D}
          {R : Type}
          (h : E ~> stateT S (ctree F D))
          (g : bool -> C ~> stateT S (ctree F D)).

  (** Unfolding of [fold]. *)
  Notation fold_state_ h g t s :=
    (match observe t with
     | RetF r => Ret (s, r)
     | VisF e k => bind (h _ e s) (fun xs => Guard (fold_state h g (k (snd xs)) (fst xs)))
     | BrF b c k => bind (g b _ c s) (fun xs => Guard (fold_state h g (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_fold_state (t : ctree E C R) (s : S) :
    fold_state h g t s ≅ fold_state_ h g t s.
  Proof.
    unfold fold_state, fold, Basics.iter, MonadIter_stateT0, iter, MonadIter_ctree.
    rewrite unfold_iter at 1.
    cbn.
    rewrite bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_fold_state:
    Proper (equ eq ==> eq ==> equ eq)
           (fold_state h g (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_fold_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma fold_state_ret
        (s : S) (r : R) :
    (fold_state h g (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma fold_state_vis {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    fold_state h g (Vis e k) s ≅ h e s >>= fun sx => Guard (fold_state h g (k (snd sx)) (fst sx)).
  Proof.
    rewrite unfold_fold_state; reflexivity.
  Qed.

  Lemma fold_state_br {T: Type} `{C -< D}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    fold_state h g (br b c k) s ≅ g b c s >>= fun sx => Guard (fold_state h g (k (snd sx)) (fst sx)).
  Proof.
    rewrite !unfold_fold_state; reflexivity.
  Qed.

  (* TODO move *)
  #[global] Instance equ_Guard:
    forall {E B : Type -> Type} {R : Type} `{B1 -< B},
      Proper (equ eq ==> equ eq) (@Guard E B R _).
  Proof.
    repeat intro.
    unfold Guard; now setoid_rewrite H1.
  Qed.

  Lemma fold_state_trigger (e : E R) (s : S) :
    fold_state h g (CTree.trigger e) s ≅
    h e s >>= fun x => Guard (Ret x).
  Proof.
    unfold CTree.trigger.
    rewrite fold_state_vis; cbn.
    upto_bind_eq; cbn.
    rewrite fold_state_ret.
    now break.
  Qed.

  Lemma fold_state_trigger_sb `{B0 -< D} (e : E R) (s : S)
    : fold_state h g (CTree.trigger e) s ~ h e s.
  Proof.
    unfold CTree.trigger. rewrite fold_state_vis.
    rewrite <- (bind_ret_r (h e s)) at 2.
    cbn.
    upto_bind_eq.
    rewrite sb_guard, fold_state_ret.
    now break.
  Qed.

  (** Unfolding of [interp]. *)
  Notation interp_state_ h t s :=
    (match observe t with
     | RetF r => Ret (s, r)
	   | VisF e k => bind (h _ e s) (fun xs => Guard (interp_state h (k (snd xs)) (fst xs)))
	   | BrF b c k => bind (mbr (M := stateT _ _) b c s) (fun xs => Guard (interp_state h (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_interp_state `{C-<D} (t : ctree E C R) (s : S) :
    interp_state h t s ≅ interp_state_ h t s.
  Proof.
    unfold interp_state, interp, Basics.iter, MonadIter_stateT0, fold, MonadIter_ctree, iter.
    rewrite unfold_iter at 1.
    cbn.
    rewrite bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_interp_state `{C-<D}:
    Proper (equ eq ==> eq ==> equ eq)
           (interp_state (C := C) h (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_interp_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma interp_state_ret `{C-<D}
        (s : S) (r : R) :
    (interp_state (C := C) h (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma interp_state_vis `{C-<D} {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    interp_state h (Vis e k) s ≅ h e s >>= fun sx => Guard (interp_state h (k (snd sx)) (fst sx)).
  Proof.
    rewrite unfold_interp_state; reflexivity.
  Qed.

  Lemma interp_state_br {T: Type} `{C -< D}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    interp_state h (Br b c k) s ≅ branch b c >>= fun x => Guard (interp_state h (k x) s).
  Proof.
    rewrite !unfold_interp_state; cbn.
    rewrite bind_bind.
    upto_bind_eq.
    rewrite bind_ret_l.
    reflexivity.
  Qed.

  Lemma interp_state_guard `{B1 -< C} `{C -< D}
    (t : ctree E C R) (s : S) :
    interp_state h (Guard t) s ≅
    brD (▷ branch1: C _) (fun _ => (Guard (interp_state h t s))).
  Proof.
    unfold Guard at 1.
    rewrite interp_state_br.
    cbn.
    unfold branch; rewrite bind_br.
    step; constructor; intros [].
    rewrite bind_ret_l.
    reflexivity.
  Qed.

  (** Unfolding of [refine]. *)
  Notation refine_state_ g t s :=
    (match observe t with
     | RetF r => Ret (s, r)
	   | VisF e k => bind (mtrigger e) (fun x => Guard (refine_state g (k x) s))
	   | BrF b c k => bind (g b _ c s) (fun xs => Guard (refine_state g (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_refine_state `{E-<F} (t : ctree E C R) (s : S) :
    refine_state g t s ≅ refine_state_ g t s.
  Proof.
    unfold refine_state, refine, Basics.iter, MonadIter_stateT0, fold, MonadIter_ctree, iter.
    rewrite unfold_iter at 1.
    cbn.
    rewrite !bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      rewrite !bind_bind.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_refine_state `{E-<F}:
    Proper (equ eq ==> eq ==> equ eq)
           (refine_state (E := E) g (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_refine_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma refine_state_ret `{E-<F}
        (s : S) (r : R) :
    (refine_state (E := E) g (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma refine_state_vis `{E-<F} {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    refine_state g (Vis e k) s ≅
      trigger e >>= fun x => Guard (refine_state g (k x) s).
  Proof.
    rewrite unfold_refine_state; reflexivity.
  Qed.

  Lemma refine_state_br {T: Type} `{E -< F}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    refine_state g (Br b c k) s ≅
    g b c s >>= fun xs => Guard (refine_state g (k (snd xs)) (fst xs)).
  Proof.
    rewrite !unfold_refine_state; cbn.
    now upto_bind_eq.
  Qed.

End State.

Section FoldBind.
  Variable (S : Type).
  Context {E F C D : Type -> Type}
    `{B1 -< D}.

  Lemma fold_state_bind
    (h : E ~> stateT S (ctree F D))
    (g : bool -> C ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    fold_state h g (t >>= k) s
      ≅ fold_state h g t s >>= fun st => fold_state h g (k (snd st)) (fst st).
  Proof.
    revert s t.
    coinduction ? IH; intros.
    rewrite (ctree_eta t).
    cbn.
    rewrite unfold_bind.
    rewrite unfold_fold_state.
    destruct (observe t) eqn:Hobs; cbn.
    - rewrite fold_state_ret. rewrite bind_ret_l. cbn.
      rewrite unfold_fold_state. reflexivity.
    - rewrite fold_state_vis.
      cbn.
      rewrite bind_bind. cbn.
      upto_bind_eq.
      rewrite bind_guard.
      constructor; intros ?; apply IH.
    - rewrite unfold_fold_state.
      cbn.

      rewrite bind_bind.
      upto_bind_eq.
      rewrite bind_guard.
      constructor; intros ?; apply IH.
  Qed.

  Lemma interp_state_bind `{C -< D}
    (h : E ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    interp_state h (t >>= k) s ≅ interp_state h t s >>= fun xs => interp_state h (k (snd xs)) (fst xs).
  Proof.
    eapply fold_state_bind.
  Qed.

  Lemma refine_state_bind `{E -< F}
    (g : bool -> C ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    refine_state g (t >>= k) s ≅ refine_state g t s >>= fun xs => refine_state g (k (snd xs)) (fst xs).
  Proof.
    eapply fold_state_bind.
  Qed.

End FoldBind.

(* Stateful handlers [E ~> stateT S (itree F)] and morphisms
   [E ~> state S] define stateful itree morphisms
   [itree E ~> stateT S (itree F)]. *)
From CTree Require Import FoldCTree.

(* TODO MOVE *)
Lemma trans_branch :
  forall {E B : Type -> Type} {X : Type} {H : B0 -< B} {Y : Type}
    [l : label] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y),
    trans l t t' -> k x ≅ t -> trans l (CTree.branch false c >>= k) t'.
Proof.
  intros.
  setoid_rewrite bind_branch.
  eapply trans_brD; eauto.
Qed.

Section transi_state.

  Variable S : Type.
  Context {E F C D : Type -> Type}
    `{CST1 : B0 -< C} {CST2 : C -< D} `{CST3 : B1 -< D} `{CST4 : E -< F}.
  Context {X : Type}.
  Variable (h : E ~> stateT S (ctree F D)).

  Lemma epsilon_interp_state : forall (t t' : ctree E C X) s,
      epsilon t t' ->
      epsilon (interp_state h t s) (interp_state h t' s).
  Proof.
    intros; red in H.
    rewrite (ctree_eta t), (ctree_eta t').
    genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
    induction H.
    - constructor. rewrite H. reflexivity.
    - rewrite unfold_interp_state. cbn.
      rewrite bind_bind.
      unfold mbr, MonadBr_ctree, CTree.branch.
      rewrite bind_br.
      eapply EpsilonBr with (x := x).
      rewrite !bind_ret_l.
      cbn.
      eapply EpsilonBr with (x := tt).
      apply IHepsilon_.
  Qed.

  (* transi *)

  Instance foo : B0 -< D.
  intros ? ?; now apply CST2, CST1.
  Defined.

  Inductive transi_state : @label F -> S -> S -> ctree E C X -> ctree E C X -> Prop :=
  | transis_val : forall (x : X) t t' s,
      trans (val x) t t' ->
      transi_state (val (s, x)) s s t t'
  | transis_tau : forall t t' s,
      trans tau t t' ->
      transi_state tau s s t t'
  | transis_obs : forall Y (e : E Y) x l t t' t'' s s',
      trans (obs e x) t t' ->
      epsilon_det t'' (Ret (s', x)) ->
      trans l (h e s) t'' ->
      transi_state l s s' t t'
  | transis_obs0 : forall Y (e : E Y) l x t t' t'' s s' s'',
      trans (obs e x) t t' ->
      transi_state l s' s'' t' t'' ->
      trans (val (s', x)) (h e s) stuckD ->
      transi_state l s s'' t t''
  .

  #[global] Instance transis_equ :
    forall l s s',
      Proper (equ eq ==> equ eq ==> flip impl) (@transi_state l s s').
  Proof.
    cbn. intros.
    revert x x0 H H0. induction H1; intros.
    - apply transis_val. rewrite H0, H1. apply H.
    - apply transis_tau. rewrite H0, H1. apply H.
    - rewrite <- H2, <- H3 in *. eapply transis_obs; eauto.
    - rewrite <- H2 in *. eapply transis_obs0; eauto.
  Qed.

  #[global] Instance transis_equ' :
    forall l s s',
      Proper (equ eq ==> equ eq ==> impl) (@transi_state l s s').
  Proof.
    cbn. intros. rewrite <- H, <- H0. apply H1.
  Qed.

  Lemma transis_brD : forall Y l s s' (t' : ctree E C X) (c : C Y) k x,
      transi_state l s s' (k x) t' ->
      transi_state l s s' (BrD c k) t'.
  Proof.
    intros. inv H.
    - apply transis_val. etrans.
    - apply transis_tau. etrans.
    - eapply transis_obs; etrans.
    - eapply transis_obs0; etrans.
  Qed.

  Lemma epsilon_transi :
    forall l s s' (t t' t'' : ctree E C X),
      epsilon t t' ->
      transi_state l s s' t' t'' ->
      transi_state l s s' t t''.
  Proof.
    intros.
    red in H. rewrite (ctree_eta t). rewrite (ctree_eta t') in H0.
    genobs t ot. genobs t' ot'. clear t Heqot. clear t' Heqot'.
    revert l t'' H0. induction H; intros.
    - rewrite H. apply H0.
    - eapply transis_brD. setoid_rewrite <- ctree_eta in IHepsilon_. apply IHepsilon_. apply H0.
  Qed.

  Lemma transis_sbisim :
    forall l s s' (t t' u : ctree E C X),
      transi_state l s s' t t' ->
      t ~ u ->
      exists u', transi_state l s s' u u' /\ t' ~ u'.
  Proof.
    intros. revert u H0.
    induction H; intros.
    - step in H0. destruct H0 as [? _]. apply H0 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_val; eauto. apply H1.
    - step in H0. destruct H0 as [? _]. apply H0 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_tau; eauto. apply H1.
    - step in H2. destruct H2 as [? _]. apply H2 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_obs; eauto. apply H3.
    - step in H2. destruct H2 as [? _]. apply H2 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      apply IHtransi_state in H3 as (? & ? & ?).
      eexists; split. eapply transis_obs0; eauto. apply H4.
  Qed.

  Lemma transis_trans (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall l s s' (t t' : ctree E C X),
      transi_state l s s' t t' ->
      exists t0, trans l (interp_state h t s) t0 /\ epsilon_det t0 (interp_state h t' s').
  Proof.
    intros. induction H.
    - exists stuckD. apply trans_val_inv in H as ?.
      apply trans_val_epsilon in H as [].
      eapply epsilon_interp_state in H. rewrite interp_state_ret in H. setoid_rewrite H0.
      setoid_rewrite interp_state_br.
      split.
      eapply epsilon_trans in H; etrans.
      left.
      setoid_rewrite bind_branch.
      step.
      constructor; intros [].

    - exists (Guard (interp_state h t' s)). split; [| eright; eauto; now left ].
      apply trans_tau_epsilon in H as (? & ? & ? & ? & ? & ?).
      eapply epsilon_interp_state in H. setoid_rewrite H0. eapply epsilon_trans; etrans.
      rewrite interp_state_br. setoid_rewrite bind_branch.
      econstructor. reflexivity.
    - exists (x <- t'';; Guard (interp_state h t' s')).
      split.
      2: { eapply epsilon_det_bind_ret_l; eauto. eright; eauto. }
      apply trans_obs_epsilon in H as (? & ? & ?).
      eapply epsilon_interp_state in H. setoid_rewrite H2. eapply epsilon_trans; etrans.
      setoid_rewrite interp_state_vis.
      eapply trans_bind_l with (k := fun sx => Guard (interp_state h (x0 (snd sx)) (fst sx))) in H1.
      setoid_rewrite epsilon_det_bind_ret_l_equ in H1 at 2; eauto. cbn in *. eapply H1.
      { intro. inv H3. apply trans_val_inv in H1. rewrite H1 in H0. inv H0. step in H3. inv H3. step in H4. inv H4. auto using void_unit_elim. }
    - destruct IHtransi_state as (? & ? & ?).
      destruct (Hh Y e s).
      2: { destruct H4. rewrite H4 in H1. apply trans_vis_inv in H1 as (? & ? & ?). step in H1. inv H1. }
      destruct H4. rewrite H4 in H1. inv_trans. subst.
      exists x0. split. 2: auto.
      apply trans_obs_epsilon in H as (? & ? & ?). eapply epsilon_interp_state in H.
      setoid_rewrite interp_state_vis in H. setoid_rewrite H4 in H. setoid_rewrite bind_ret_l in H.
      eapply epsilon_trans; etrans. setoid_rewrite <- H1. etrans.
  Qed.

  Lemma interp_state_ret_inv :
    forall s (t : ctree E C X) r,
      interp_state h t s ≅ Ret r -> t ≅ Ret (snd r) /\ s = fst r.
  Proof.
    intros. setoid_rewrite (ctree_eta t) in H. setoid_rewrite (ctree_eta t).
    destruct (observe t) eqn:?.
    - rewrite interp_state_ret in H. step in H. inv H. split; reflexivity.
    - rewrite interp_state_vis in H. apply ret_equ_bind in H as (? & ? & ?). step in H0. inv H0.
    - rewrite interp_state_br in H. step in H. inv H.
  Qed.

  Lemma trans_interp_state_inv_gen (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall Y l s (k : Y -> ctree E C X) t' (pre : ctree F D Y),
      is_simple pre ->
      trans l (x <- pre;; interp_state h (k x) s) t' ->
      exists t0 s', epsilon_det t' (interp_state h t0 s') /\
                 ((exists l t1 x, trans l pre t1 /\ epsilon_det t1 (Ret x : ctree F D Y) /\ t0 ≅ k x) \/
                    exists (x : Y), trans (val x) pre stuckD /\ trans l (interp_state h (k x) s) t' /\ transi_state l s s' (k x) t0).
  Proof.
    intros * Hpre H.
    do 3 red in H. remember (observe (x <- pre;; interp_state h (k x) s)) as oi.
    setoid_rewrite (ctree_eta t') at 1.
    setoid_rewrite (ctree_eta t') at 2.
    genobs t' ot'. clear t' Heqot'.
    assert (go oi ≅ x <- pre;; interp_state h (k x) s).
    { rewrite Heqoi, <- ctree_eta. reflexivity. } clear Heqoi.
    revert Y s k pre Hpre H0. induction H; intros.
    - symmetry in H0. apply br_equ_bind in H0 as ?.
      destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0. setoid_rewrite H1. clear pre Hpre H1.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply br_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
          --setoid_rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
            inv_equ.
            rewrite <- EQ in H.
            specialize (IHtrans_ _ (fst x1) (fun (_ : unit) => k1 (snd x1)) (Ret tt)).
            edestruct IHtrans_ as (? & ? & ?).
            { apply is_simple_ret. }
            { rewrite <- ctree_eta. setoid_rewrite bind_ret_l. setoid_rewrite EQ. reflexivity. }
            destruct H0. exists x2, x3. split; auto. right. destruct H2.
            { destruct H2 as (? & ? & ? & ? & ? & ?). inv_trans. subst.
              inv H3. step in H2. inv H2. step in H5. inv H5.
              exfalso; now apply void_unit_elim.
            }
            destruct H2 as (_ & _ & ? & ?). exists x0. split. etrans. split.
            ++setoid_rewrite (ctree_eta (k0 x0)). rewrite Heqc0.
              setoid_rewrite interp_state_vis. setoid_rewrite H1. setoid_rewrite bind_ret_l. apply trans_guard. apply H2.
            ++setoid_rewrite (ctree_eta (k0 x0)). rewrite Heqc0. destruct x1.
              eapply transis_obs0. etrans. 2: { rewrite H1. etrans. } cbn in H3. cbn in *. etrans.
          -- destruct (Hh _ e s).
             destruct H3. rewrite H3 in H1. step in H1. inv H1.
             destruct H3. rewrite H3 in H1. step in H1. inv H1.
        * rewrite interp_state_br in H0.
          setoid_rewrite bind_branch in H0.
          inv_equ.
          specialize (IHtrans_ _ s (fun _ : unit => k1 x) (Guard (Ret tt))).
          edestruct IHtrans_ as (? & ? & ? & ?).
          { apply is_simple_guard_ret. }
          { rewrite <- ctree_eta. setoid_rewrite bind_br. setoid_rewrite bind_ret_l. now rewrite <- EQ. }
          destruct H1.
          { destruct H1 as (? & ? & ? & ? & ? & ?). inv_trans. subst.
            inv H2. step in H1. inv H1. step in H3. inv H3.
            exfalso; now apply void_unit_elim.
          }
          destruct H1 as (? & ? & ? & ?).
          exists x1, x2. split; auto. right. exists x0. split; etrans. split.
          rewrite (ctree_eta (k0 x0)), Heqc0, interp_state_br.
          eapply trans_branch.
          2: reflexivity. apply trans_guard. apply H2.
          rewrite (ctree_eta (k0 x0)), Heqc0. eapply transis_brD; etrans.
      + specialize (IHtrans_ _ s k0 (x0 x)).
        edestruct IHtrans_ as (? & ? & ? & ?).
        { eapply is_simple_brD. red. setoid_rewrite <- H1. apply Hpre. }
        rewrite <- ctree_eta. apply H2. destruct H4 as [(? & ? & ? & ? & ? & ?) | (? & ? & ? & ?)].
        exists (k0 x5), x2. split. { now rewrite H6 in H3. }
        left. eapply trans_brD in H4. 2: reflexivity. rewrite <- H1 in H4. eauto 6.
        * exists x1, x2. split; auto. right. exists x3. rewrite H1. etrans.
    - symmetry in H0. apply br_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply br_equ_bind in H0 as ?.
          destruct H2 as [[] | (? & ? & ?)].
          { rewrite H2 in H0. setoid_rewrite bind_ret_l in H0. step in H0. inv H0. }
          pose proof (trans_brS c x1 x). rewrite <- H2 in H4.
          edestruct Hh. { destruct H5. rewrite H5 in H4. inv_trans. }
          destruct H5. rewrite H5 in H4. apply trans_vis_inv in H4 as (? & ? & ?). discriminate.
        * rewrite interp_state_br in H0.
          setoid_rewrite bind_branch in H0.
          inv_equ.
          specialize (EQ x). rewrite H in EQ.
          exists (k1 x), s. symmetry in EQ. split.
          { rewrite <- ctree_eta. rewrite EQ. eapply epsilon_det_tau; auto. }
          right. exists x0. rewrite H1. split; etrans.
          split; setoid_rewrite (ctree_eta (k0 x0)); setoid_rewrite Heqc0.
          { setoid_rewrite interp_state_br. rewrite EQ.
            setoid_rewrite bind_branch.
            econstructor. now rewrite <- ctree_eta. }
          econstructor; etrans.
      + pose proof (trans_brS c x0 x).
        rewrite <- H1 in H3. edestruct Hpre.
        { apply H4 in H3. inv H3. }
        apply H4 in H3 as [].
        specialize (H2 x).
        exists (k0 x1), s. rewrite H in H2. split.
        { rewrite <- ctree_eta, H2. eapply epsilon_det_bind_ret_l; eauto. }
        left. exists tau, (x0 x), x1. split; auto. rewrite H1. etrans.
    - symmetry in H0. apply vis_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply vis_equ_bind in H0 as ?.
          destruct H2 as [[] | (? & ? & ?)].
          { rewrite H2 in H0. setoid_rewrite bind_ret_l in H0. step in H0. inv H0. }
          pose proof (trans_vis e x x1). rewrite <- H2 in H4.
          edestruct Hh. { destruct H5. rewrite H5 in H4. inv H4. }
          destruct H5. rewrite H5 in H4.
          specialize (H3 x). rewrite H5 in H2.
          inv_equ.
          rewrite <- EQ in *. rewrite bind_ret_l in H3.
          exists (k1 (snd x)), (fst x).
          rewrite H in H3. split. { rewrite <- ctree_eta, H3. eright; eauto. }
          right.
          exists x0. rewrite H1. split; etrans.
          split; setoid_rewrite (ctree_eta (k0 x0)); setoid_rewrite Heqc.
          { setoid_rewrite interp_state_vis. rewrite H5. setoid_rewrite bind_vis.
            econstructor. rewrite bind_ret_l. rewrite <- H3, <- ctree_eta. reflexivity. }
          eapply transis_obs; etrans. rewrite H5. destruct x. etrans.
        * rewrite interp_state_br in H0. step in H0. inv H0.
      + pose proof (trans_vis e x x0).
        rewrite <- H1 in H3. edestruct Hpre.
        { apply H4 in H3. inv H3. }
        apply H4 in H3 as [].
        specialize (H2 x).
        exists (k0 x1), s. rewrite H in H2. split.
        { rewrite <- ctree_eta, H2. eapply epsilon_det_bind_ret_l; eauto. }
        left. exists (obs e x), (x0 x), x1. split; auto. rewrite H1. etrans.
    - exists stuckD, (fst r). split.
      + left. unfold stuck. rewrite interp_state_br.
        rewrite !br0_always_stuck.
        setoid_rewrite bind_branch.
        step.
        constructor; intros [].
      + right. symmetry in H0. apply ret_equ_bind in H0 as (? & ? & ?).
        exists x. rewrite H. split; etrans. split.
        rewrite H0. rewrite br0_always_stuck. etrans.
        apply interp_state_ret_inv in H0 as []. subst. rewrite H0. destruct r. cbn. apply transis_val. econstructor; etrans.
  Qed.

  Lemma trans_interp_state_inv (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall l (t : ctree E C X) t' s,
      trans l (interp_state h t s) t' ->
      exists l t0 s', epsilon_det t' (interp_state h t0 s') /\ transi_state l s s' t t0.
  Proof.
    intros.
    assert (trans l (Guard (Ret tt);; interp_state h t s) t').
    { cbn. etrans. }
    eapply trans_interp_state_inv_gen in H0; eauto. destruct H0 as (? & ? & ? & ?).
    destruct H1 as [(? & ? & ? & ? & ? & ?) | (? & ? & ? & ?)].
    - inv_trans. subst. inv H2. step in H1. inv H1. step in H3. inv H3.
      exfalso; now apply void_unit_elim.
    - inv_trans. subst. eauto.
    - left. intros. inv_trans. subst. constructor.
  Qed.

(** The main theorem stating that fold_state preserves sbisim. *)

  Theorem interp_state_sbisim_gen {Y} (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall s (k k' : Y -> ctree E C X) (pre pre' : ctree F D Y),
      (forall x, sbisim eq (k x) (k' x)) ->
      pre ≅ pre' ->
      vsimple pre ->
      sbisim eq (a <- pre;; Guard (interp_state h (k a) s)) (a <- pre';; Guard (interp_state h (k' a) s)).
  Proof.
    revert Y. coinduction R CH.
    (* We would like to use a symmetry argument here, as is done in the 0.1 branch *)
    symmetric using idtac.
    { intros. apply H. now symmetry. now symmetry. red. now setoid_rewrite <- H1. }
    assert (CH' : forall (t t' : ctree E C X) s, t ~ t' -> st eq R (interp_state h t s) (interp_state h t' s)).
    {
      intros.
      assert (st eq R (a <- Ret tt;; Guard (interp_state h ((fun _ => t) a) s))
                (a <- Ret tt;; Guard (interp_state h ((fun _ => t') a) s))).
      { apply CH; eauto. left; eauto. }
      setoid_rewrite bind_ret_l in H0.
      rewrite !sb_guard in H0.
      apply H0.
    }
    intros. setoid_rewrite <- H0. clear pre' H0. cbn.
    cbn; intros.
    copy H0. rewrite bind_guard_r in H0.
    eapply trans_interp_state_inv_gen in H0 as (? & ? & ? & ?); auto.
    2: { destruct H1 as [[] | []]; rewrite H1.
         rewrite bind_ret_l. apply is_simple_guard_ret.
         rewrite bind_trigger. right. intros. inv_trans. subst.
         exists x0. rewrite EQ. eright. left. reflexivity. reflexivity.
    }
    destruct H2.
    + destruct H2 as (? & ? & ? & ? & ? & ?). rewrite H4 in H0. clear x H4.
      destruct H1 as [[] | []].
      * rewrite H1, bind_ret_l in H2. rewrite H1, bind_ret_l in cpy. inv_trans. subst.
        inv H3. step in H2. inv H2. step in H4. inv H4.
        exfalso; now apply void_unit_elim.
      * rewrite H1 in *. rewrite bind_trigger in H2. apply trans_vis_inv in H2 as (? & ? & ?). subst.
        rewrite H2 in H3. inv H3. step in H4. inv H4.
        apply equ_br_invE in H5 as [_ ?].
        rewrite <- H3 in H4; auto. inv H4.
        2: { step in H6. inv H6. }
        step in H5. inv H5.
        rewrite bind_trigger in cpy. apply trans_vis_inv in cpy. destruct cpy as (? & ? & ?). subst.
        eexists. exists (Guard (interp_state h (k' x1) s)). rewrite H1. rewrite bind_trigger. split.
        now constructor.
        split; auto.
        rewrite H4, !sb_guard. apply CH'. apply H.
    + destruct H2 as (? & ? & ? & ?).
      destruct H1 as [[] | []].
      2: { rewrite H1 in H2. setoid_rewrite bind_trigger in H2. inv_trans. }
      rewrite H1 in *. rewrite bind_ret_l in H2. inv_trans. subst. clear EQ.
      eapply transis_sbisim in H4; eauto. destruct H4 as (? & ? & ?).
      apply transis_trans in H2 as (? & ? & ?); auto.
      eexists; exists x3. rewrite H1, bind_ret_l. split.
      etrans.
      assert (st eq R (interp_state h x x0) (interp_state h x1 x0)).
      { apply CH'. apply H4. }
      split; auto.
      rewrite sbisim_epsilon_det. 2: apply H0.
      apply sbisim_epsilon_det in H5; rewrite H5.
      apply H6.
  Qed.

  #[global] Instance interp_state_sbisim (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    Proper (sbisim eq ==> eq ==> sbisim eq) (interp_state h (C := C) (T := X)).
  Proof.
    cbn. intros. subst.
    assert (a <- Ret tt;; Guard (interp_state h ((fun _ => x) a) y0) ~
                           a <- Ret tt;; Guard (interp_state h ((fun _ => y) a) y0)).
    apply interp_state_sbisim_gen; auto.
    red; eauto.
    setoid_rewrite bind_ret_l in H0. rewrite !sb_guard in H0. apply H0.
  Qed.

End transi_state.

Arguments get {S E C _}.
Arguments put {S E C _}.
Arguments run_state {S E C} [_] _ _.
Arguments fold_state {E C M S FM MM IM} h g [T].
Arguments interp_state {E C M S FM MM IM BM} h [T].
Arguments refine_state {E C M S FM MM IM TM} g [T].


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal33.

Set Printing Depth 1000.
Definition lfind_eval :=
@eq.

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q C0 : Universe, ((wd_ C0 A /\ (wd_ A B /\ (wd_ C0 B /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ P C0 /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (col_ A B P /\ (col_ C D C0 /\ (col_ C0 P A /\ col_ C0 P B)))))))))))))))) -> col_ C0 A B)).
Proof.
  time tac.
Qed.

End FOFProblem.