(*|
=================================
Denotation of [ccs] into [ctree]s
=================================

.. coq:: none
|*)

From Coq Require Export
     List
     Strings.String.
From Coq Require Import RelationClasses Program.

From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

From CTreeCCS Require Import
     Syntax.

From CTree Require Import Head.
From CTree Require Import
     CTree
     Eq
     Eq.SBisim
     Interp.Fold
     Interp.FoldCTree.

Import CTree.

Import CTreeNotations.
Open Scope ctree_scope.

(*|
Event signature
---------------
Processes must at least be able to perform actions.
We do not encode tau steps as events but rather directly as
unary visible br nodes.
|*)

Variant ActionE : Type -> Type :=
  | Act (a : action) : ActionE unit.

Notation ccsE := ActionE.
Notation ccsC := (B0 +' B1 +' B2 +' B3 +' B4).

Definition ccsT' T := ctree' ccsE ccsC T.
Definition ccsT := ctree ccsE ccsC.

Definition ccs' := ccsT' void.
Definition ccs  := ccsT void.

Definition comm a : label := obs (Act a) tt.

(*| Process algebra |*)
Section Combinators.

  Definition nil : ccs := stuckS.

  Definition prefix (a : action) (P: ccs) : ccs :=
    trigger (Act a);; P.

  Definition plus (P Q : ccs) : ccs := brD2 P Q.

  (* Stuck? Failure event? *)
  Definition h_new (c : chan) : ActionE ~> ctree ccsE ccsC :=
    fun _ e => let '(Act a) := e in
            match a with
            | Send c'
            | Rcv c' =>
                if (c =? c')%string then stuckD else trigger e
            end.
  #[global] Arguments h_new c [T] _.

  Definition new : chan -> ccs -> ccs :=
    fun c P => interp (h_new c) P.

  Definition para : ccs -> ccs -> ccs :=
    cofix F (P : ccs) (Q : ccs) :=
      brD3
        (rP <- head P;;
         match rP with
         | ARet rP => match rP with end
         | ABr c kP => BrS c (fun i => F (kP i) Q)
         | AVis e kP => Vis e (fun i => F (kP i) Q)
         end)

        (rQ <- head Q;;
         match rQ with
         | ARet rQ => match rQ with end
         | ABr c kQ => BrS c (fun i => F P (kQ i))
         | AVis e kQ => Vis e (fun i => F P (kQ i))
         end)

        (rP <- head P;;
         rQ <- head Q;;
         match rP, rQ with
         | AVis eP kP, AVis eQ kQ =>
             match eP, kP, eQ, kQ with
             | Act a, kP, Act b, kQ =>
                 if are_opposite a b
                 then
                   Step (F (kP tt) (kQ tt))
                 else
                   stuckD
             end
         | _, _ => stuckD
         end).

(*|
We would like to define [bang] directly as in the following.
Unfortunately, it is not syntactically guarded and convincing Coq
seems challenging.
We therefore instead define a more general function [parabang] expressing
at once the parallel composition of a process [p] with a server of [q].
The usual [bang p] is then defined as [parabang p p].
|*)
  Fail Definition bang : ccs -> ccs :=
    cofix bang (p : ccs ) : ccs := para (bang p) p.

  Definition parabang : ccs -> ccs -> ccs :=
    cofix pB (p : ccs) (q:ccs) : ccs :=
      brD4
        (* Communication by p *)
        (rp <- head p;;
         match rp with
         | ARet rp => match rp with end
         | ABr c kp => BrS c (fun i =>  pB (kp i) q )
         | AVis e kp => Vis e (fun i => pB (kp i) q)
         end)

        (* Communication by a fresh copy of q *)
        (rq <- head q;;
         match rq with
         | ARet rq => match rq with end
         | ABr c kq => BrS c (fun i => (pB  (para p (kq i)) q))
         | AVis e kq => Vis e (fun i => (pB  (para p (kq i)) q))
         end)

        (* Communication between p and a fresh copy of q *)
        (rp <- head p;;
         rq <- head q;;
         match rp, rq with
         | AVis ep kp, AVis eq kq =>
             match ep, kp, eq, kq with
             | Act a, kp, Act b, kq =>
                 if are_opposite a b
                 then
                   Step (pB (para (kp tt) (kq tt)) q)
                 else
                   stuckD
             end

         | _, _ => stuckD
         end)

        (* Communication between two fresh copies of q *)
        (rq1 <- head q;;
         rq2 <- head q;;
         match rq1, rq2 with
         | AVis eq1 kq1, AVis eq2 kq2 =>
             match eq1, kq1, eq2, kq2 with
             | Act a, kq1, Act b, kq2 =>
                 if are_opposite a b
                 then
                   Step (pB (para p (para (kq1 tt) (kq2 tt))) q)
                 else
                   stuckD
             end

         | _, _ => stuckD
         end).

  Definition bang (P : ccs) : ccs := parabang P P.

End Combinators.

Module CCSNotationsSem.

  Declare Scope ccs_scope.

  Notation "0" := nil: ccs_scope.
  Infix "+" := plus (at level 50, left associativity) : ccs_scope.
  (* Infix "∥" := communicating (at level 29, left associativity). *)
  Infix "∥" := para (at level 29, left associativity) : ccs_scope.
  Notation "! x" := (bang x) : ccs_scope.

End CCSNotationsSem.

Import CCSNotationsSem.
Open Scope ccs_scope.

(** TODO: Move these to [SSim.v] ? *)
#[global] Instance equ_clos_sb_goal {E X} RR :
  Proper (equ eq ==> equ eq ==> flip impl)
         (@sb E E ccsC ccsC X X _ _ eq RR).
Proof.
  cbn; unfold Proper, respectful; intros * eq1 * eq2 bis.
  destruct bis as [F B]; cbn in *.
  split.
  + intros ? ? TR.
    rewrite eq1 in TR.
    apply F in TR as (l1 & y1 & TR & ? & ->).
    do 2 eexists.
    rewrite eq2; eauto.
  + intros ? ? TR.
    rewrite eq2 in TR.
    apply B in TR as (l1 & y1 & TR & ? & <-).
    do 2 eexists.
    rewrite eq1; eauto.
Qed.

#[global] Instance equ_clos_sb_ctx {E X} RR :
  Proper (gfp (@fequ E ccsC X X eq) ==> equ eq ==> impl)
         (@sb E E ccsC ccsC X X _ _ eq RR).
Proof.
  cbn; unfold Proper, respectful; intros * eq1 * eq2 bis.
  destruct bis as [F B]; cbn in *.
  split.
  + intros ? ? TR.
    rewrite <- eq1 in TR.
    apply F in TR as (l1 & y1 & TR & ? & ->).
    do 2 eexists.
    rewrite <- eq2; eauto.
  + intros ? ? TR.
    rewrite <- eq2 in TR.
    apply B in TR as (l1 & y1 & TR & ? & <-).
    do 2 eexists.
    rewrite <- eq1; eauto.
Qed.

Lemma trans_prefix_inv : forall l a p p',
    trans l (prefix a p) p' ->
    p' ≅ p /\ l = comm a.
Proof.
  intros * tr.
  apply trans_trigger_inv in tr as (? & ? & ->).
  destruct x; split; auto.
Qed.

Lemma trans_prefix : forall a p,
    trans (comm a) (prefix a p) p.
Proof.
  intros; eapply trans_trigger.
Qed.

(** TODO: Hm should probably recover [Symmetric] for [st eq] *)
(** ** prefix *)
Lemma ctx_prefix_st a: unary_ctx (prefix a) <= st eq.
Proof.
  apply Coinduction, by_Symmetry. apply unary_sym.
  rewrite <-b_T.
  intro R. apply (leq_unary_ctx (prefix a)). intros p q Hpq.
  intros l p' pp'.
  apply trans_prefix_inv in pp' as (EQ & ->).
  do 2 eexists; split.
  apply trans_prefix.
  rewrite EQ; auto.
Qed.

(** ** prefix *)
Lemma ctx_prefix_tequ a: unary_ctx (prefix a) <= (et eq).
Proof.
  apply Coinduction.
  intro R.
  apply (leq_unary_ctx (prefix a)).
  intros p q Hpq.
  cbn in *.
  constructor.
  intros [].
  fold (@bind ccsE _ _ _ (Ret tt) (fun _ => p)).
  fold (@bind ccsE _ _ _ (Ret tt) (fun _ => q)).
  rewrite 2 unfold_bind; cbn.
  apply (b_T (fequ eq)).
  apply Hpq.
Qed.

#[global] Instance prefix_st a: forall R, Proper (st eq R ==> st eq R) (prefix a) := unary_proper_t (@ctx_prefix_st a).

#[global] Instance prefix_tequ a: forall R, Proper (et eq R ==> et eq R) (prefix a) := unary_proper_t (@ctx_prefix_tequ a).

Definition can_comm (c : chan) (a : @label ccsE) : bool :=
  match a with
  | obs (Act a) _ =>
      match a with
      | Send c'
      | Rcv c' => if (c =? c')%string then false else true
      end
  | _ => true
  end.

Lemma trans_trigger_inv' : forall {E C X} `{B0 -< C} (e : E X) l u,
		trans l (trigger e : ctree E C X) u ->
    exists x, u ≅ Ret x /\ l = obs e x.
Proof.
  intros * TR.
  unfold trigger in TR.
  now apply trans_vis_inv in TR.
Qed.

Lemma trans_hnew_inv : forall a l c p,
    trans l (h_new c (Act a)) p ->
    l = obs (Act a) tt /\ can_comm c l /\ p ≅ Ret tt.
Proof.
  intros * tr.
  cbn in *; destruct a; cbn in *; destruct (c =? c0) eqn:comm; cbn in *.
  all : try now eapply stuckD_is_stuck in tr.
  all: unfold can_comm; apply trans_trigger_inv' in tr as ([] & ? & ?); subst; rewrite comm; eauto.
Qed.

Lemma trans_vis' {E C R X} `{B0 -< C} : forall (e : E X) x (k : X -> ctree E C R) u,
    u ≅ k x ->
    trans (obs e x) (Vis e k) u.
Proof.
  intros * eq; rewrite eq; apply trans_vis.
Qed.

Lemma new_guard : forall c t, new c (Guard t) ≅ Guard (Guard (new c t)).
Proof.
  intros; unfold new; now rewrite interp_guard.
Qed.

#[global] Instance new_equ c :
  Proper (equ eq ==> equ eq) (new c).
Proof.
  apply interp_equ.
Qed.

Lemma trans_new : forall l c p p',
    trans l p p' ->
    can_comm c l = true ->
    exists q, trans l (new c p) q /\ q ~ new c p'.
Proof.
  intros * tr comm.
  do 3 red in tr.
  genobs p obsp; genobs p' op'.
  revert p p' Heqobsp Heqop'.
  induction tr; intros.
  - edestruct IHtr as (q & tr' & eq); eauto.
    exists q; split; auto.
    unfold new; rewrite unfold_interp, <- Heqobsp.
    cbn; unfold Utils.mbr, MonadBr_ctree, branch.
    eapply trans_bind_r with x.
    eapply trans_brD; [|reflexivity].
    apply trans_ret.
    apply trans_guard.
    apply tr'.
  - eexists; split.
    unfold new; rewrite unfold_interp, <- Heqobsp.
    cbn; unfold Utils.mbr, MonadBr_ctree, branch.
    eapply trans_bind_l.
    intros abs; inv abs.
    apply trans_brS with (x := x).
    rewrite bind_ret_l, sb_guard.
    rewrite H.
    unfold new. rewrite unfold_interp.
    rewrite <- Heqop', <- unfold_interp.
    reflexivity.
  - destruct e, a.
    all: cbn in *; destruct (c =? c0) eqn:comm'; inv comm.
    + eexists; split.
      unfold new; rewrite unfold_interp, <- Heqobsp.
      cbn; unfold Utils.mbr, MonadBr_ctree, branch.
      eapply trans_bind_l.
      intros abs; inv abs.
      rewrite comm'.
      unfold trigger.
      eapply trans_vis'.
      reflexivity.
      rewrite bind_ret_l, sb_guard, H.
      unfold new.
      rewrite unfold_interp.
      rewrite <- Heqop', <- unfold_interp.
      reflexivity.
    + eexists; split.
      unfold new; rewrite unfold_interp, <- Heqobsp.
      cbn; unfold Utils.mbr, MonadBr_ctree, branch.
      eapply trans_bind_l.
      intros abs; inv abs.
      rewrite comm'.
      unfold trigger.
      eapply trans_vis'.
      reflexivity.
      rewrite bind_ret_l, sb_guard, H.
      unfold new.
      rewrite unfold_interp.
      rewrite <- Heqop', <- unfold_interp.
      reflexivity.
  - tauto.
Qed.

Lemma trans_new_inv_aux : forall l T U,
    trans_ l T U ->
    forall c p q,
      (go T ≅ new c p \/ go T ≅ Guard (new c p)) ->
      go U ≅ q ->
      exists q', can_comm c l = true /\ trans l p q' /\ q ≅ Guard (new c q').
Proof.
  intros * tr c.
  induction tr; intros * EQ1 EQ2; try destruct c2.
  - destruct EQ1 as [EQ1 | EQ1].
    + unfold new in EQ1; rewrite unfold_interp in EQ1.
      unfold trans, transR.
      cbn.
      desobs p; try now step in EQ1; inv EQ1.
      * destruct e,a; cbn in *.
        ** destruct (c =? c1); cbn in *.
           *** step in EQ1; dependent induction EQ1; inv x0.
           *** step in EQ1; inv EQ1.
        ** destruct (c =? c1); cbn in *.
           *** step in EQ1; dependent induction EQ1; inv x0.
           *** step in EQ1; inv EQ1.
      * cbn in EQ1.
        destruct vis; try now step in EQ1; inv EQ1.
        unfold Utils.mbr, MonadBr_ctree, branch in EQ1.
        cbn in * |-.
        rewrite unfold_bind in EQ1; cbn in EQ1.
        inv_equ. rename EQ into eqx.
        specialize (eqx x).
        cbn in * |-; rewrite bind_ret_l in eqx.
        setoid_rewrite <- ctree_eta in IHtr.
        setoid_rewrite eqx in IHtr.
        edestruct (IHtr (k0 x)) as (q' & comm & tr' & EQ); [right; reflexivity | reflexivity |].
        exists q'; repeat split; auto.
        eapply trans_brD with (x := x).
        eauto.
        reflexivity.
        rewrite <- EQ, EQ2; auto.
    + inv_equ. rename EQ into eqx.
      specialize (eqx x).
      edestruct IHtr as (q' & comm & tr' & EQ); [| eassumption |].
      left. rewrite eqx, <- ctree_eta; reflexivity.
      exists q'; repeat split; auto.
  - destruct EQ1 as [EQ1 | EQ1]; [ | step in EQ1; dependent induction EQ1].
    unfold new in EQ1; rewrite unfold_interp in EQ1.
    unfold trans,transR; cbn.
    desobs p; try now step in EQ1; inv EQ1.
    + cbn in *.
      destruct e,a; cbn in *; destruct (c =? c1) eqn:EQ; step in EQ1; dependent induction EQ1.
    + cbn in *.
      unfold Utils.mbr, MonadBr_ctree, branch in EQ1.
      destruct vis; try now step in EQ1; inv EQ1.
      rewrite unfold_bind in EQ1; cbn in EQ1.
      inv_equ. rename EQ into eqx.
      specialize (eqx x).
      rewrite bind_ret_l in eqx.
      rewrite H in eqx.
      rewrite <- ctree_eta in EQ2.
      rewrite EQ2 in eqx.
      clear k t EQ2 H.
      exists (k0 x); repeat split.
      apply trans_brS.
      auto.
  - destruct EQ1 as [EQ1 | EQ1]; [ | step in EQ1; inv EQ1].
    unfold new in EQ1; rewrite unfold_interp in EQ1.
    unfold trans,transR; cbn.
    desobs p; try now step in EQ1; inv EQ1.
    cbn in *.
    destruct e0,a; cbn in *; destruct (c =? c0) eqn:EQ; try now step in EQ1; inv EQ1.
    all:unfold trigger in EQ1; rewrite unfold_bind in EQ1; cbn in EQ1; setoid_rewrite bind_ret_l in EQ1.
    all: inv_equ; rename EQ0 into eqx.
    all:rewrite EQ.
    all:specialize (eqx x).
    all:rewrite H in eqx; rewrite <- ctree_eta in EQ2; rewrite EQ2 in eqx.
    all: exists (k0 x); repeat split; auto.
    all: apply trans_vis.
  - tauto.
Qed.

Lemma trans_new_inv : forall l c p p',
    trans l (new c p) p' ->
    exists q, can_comm c l = true /\ trans l p q /\ p' ≅ Guard (new c q).
Proof.
  intros; eapply trans_new_inv_aux. eapply H.
  all: rewrite <- ctree_eta; auto.
Qed.

Lemma trans_new_inv' : forall l c p p',
    trans l (new c p) p' ->
    exists q, can_comm c l = true /\ trans l p q /\ p' ~ new c q.
Proof.
  intros; edestruct trans_new_inv as (? & ? & ? & ?); eauto.
  eexists; repeat split; eauto.
  rewrite H2, sb_guard; reflexivity.
Qed.

(** ** name restriction *)
Lemma ctx_new_st a: unary_ctx (new a) <= st eq.
Proof.
  apply Coinduction, by_Symmetry. apply unary_sym.
  intro R. apply (leq_unary_ctx (new a)). intros p q Hpq l p0 Hp0.
  apply trans_new_inv in Hp0 as (? & comm & tr & EQ).
  destruct (proj1 Hpq _ _ tr) as (? & ? & TR & ? & ->).
  eapply trans_new in TR as (q' & tr' & eq'); eauto.
  eexists; exists q'; eauto.
  split; [|split]; eauto.
  rewrite EQ.
  rewrite eq'.
  rewrite sb_guard.
  apply unary_proper_Tctx, (id_T (sb eq)).
  auto.
Qed.

#[global] Instance new_st a: forall R, Proper (st eq R ==> st eq R) (new a) := unary_proper_t (@ctx_new_st a).

Lemma trans_plus_inv : forall l p q r,
    trans l (p + q) r ->
    (exists p', trans l p p' /\ r ≅ p') \/
      (exists q', trans l q q' /\ r ≅ q').
Proof.
  intros * tr.
  apply trans_brD_inv in tr as ([|] & tr); eauto.
Qed.

Lemma trans_brS' {E C X Y} `{B0 -< C} : forall (c : C Y) (k : Y -> ctree E C X) x u,
    u ≅ k x ->
		trans tau (BrS c k) u.
Proof.
  intros * eq; rewrite eq; apply trans_brS.
Qed.

Lemma trans_plusL : forall l p p' q,
    trans l p p' ->
    trans l (p + q) p'.
Proof.
  intros * tr.
  now apply trans_brD21.
Qed.

Lemma trans_plusR : forall l p q q',
    trans l q q' ->
    trans l (p + q) q'.
Proof.
  intros * tr.
  now apply trans_brD22.
Qed.

(** ** br *)
Lemma ctx_plus_t: binary_ctx plus <= st eq.
Proof.
  apply Coinduction, by_Symmetry. apply binary_sym.
  intro R. apply (leq_binary_ctx plus).
  intros * [F1 B1] * [F2 B2] ? * tr.
  apply trans_plus_inv in tr as [(? & tr & EQ) | (? & tr & EQ)].
  - apply F1 in tr as [? (? & tr & ? & ->)].
    do 2 eexists; split; [|split].
    apply trans_plusL; eauto.
    rewrite EQ.
    now apply (id_T (sb eq)).
    reflexivity.
  - apply F2 in tr as [? (? & tr & ? & <-)].
    do 2 eexists; split; [|split].
    apply trans_plusR; eauto.
    rewrite EQ.
    now apply (id_T (sb eq)).
    reflexivity.
Qed.

#[global] Instance plus_t:
  forall R, Proper (st eq R ==> st eq R ==> st eq R) plus := binary_proper_t ctx_plus_t.

Notation para_ p q :=
  (brD3
     (rp <- head p;;
      match rp with
      | ARet rp => match rp with end
      | ABr c kp => BrS c (fun i => para (kp i) q)
      | AVis e kp => Vis e (fun i => para (kp i) q)
      end)

     (rq <- head q;;
      match rq with
      | ARet rq => match rq with end
      | ABr c kq => BrS c (fun i => para p (kq i))
      | AVis e kq => Vis e (fun i => para p (kq i))
      end)

     (rp <- head p;;
      rq <- head q;;
      match rp, rq with
      | AVis ep kp, AVis eq kq =>
          match ep, kp, eq, kq with
          | Act a, kp, Act b, kq =>
              if are_opposite a b
              then
                Step (para (kp tt) (kq tt))
              else
                stuckD
          end
      | _, _ => stuckD
      end))%ctree.

Lemma unfold_para : forall p q, para p q ≅ para_ p q.
Proof.
  intros.
  now step.
Qed.

#[global] Instance para_equ :
  Proper (equ eq ==> equ eq ==> equ eq) para.
Proof.
  unfold Proper, respectful.
  coinduction R CIH.
  intros p1 p2 EQp q1 q2 EQq.
  rewrite 2 unfold_para.
  constructor.
  intros i.
  destruct i.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    inv eqp; auto.
    step; constructor; auto.
    step; constructor; auto.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    inv eqp; auto.
    step; constructor; auto.
    step; constructor; auto.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    upto_bind; [apply head_equ; auto | intros hdq1 hdq2 eqq].
    inv eqp; auto.
    inv eqq; auto.
    destruct e, e0, (are_opposite a a0); auto.
    step; constructor; auto.
Qed.

Lemma trans_paraSynch : forall a b (p p' q q' : ccs),
    trans (comm a) p p' ->
    trans (comm b) q q' ->
    are_opposite a b ->
    trans tau (p ∥ q) (p' ∥ q').
Proof.
  intros * TRp TRq Op.
  apply trans_head in TRp as (kp & TRp & Eqp).
  apply trans_head in TRq as (kq & TRq & Eqq).
  rewrite unfold_para.
  apply trans_brD33.
  eapply trans_bind_r; [apply TRp |].
  eapply trans_bind_r; [apply TRq |].
  cbn; rewrite Op.
  rewrite Eqp, Eqq.
  apply trans_step.
Qed.

Lemma trans_paraL :
  forall l (p p' q : ccs),
    trans l p p' ->
    trans l (p ∥ q) (p' ∥ q).
Proof.
  intros * TRp.
  rewrite unfold_para.
  apply trans_brD31.
  destruct l.
  - apply trans_head in TRp.
    destruct TRp as (? & ? & ? & ? & TRp & Eqp).
    eapply trans_bind_r; eauto; cbn.
    econstructor.
    rewrite Eqp; reflexivity.
  - apply trans_head in TRp.
    destruct TRp as (? & TRp & Eqp).
    eapply trans_bind_r; eauto; cbn.
    constructor.
    rewrite Eqp; reflexivity.
  - pose proof (trans_val_invT TRp); subst; easy.
Qed.

Lemma trans_paraR :
  forall l (p q q' : ccs),
    trans l q q' ->
    trans l (p ∥ q) (p ∥ q').
Proof.
  intros * TRq.
  rewrite unfold_para.
  apply trans_brD32.
  destruct l.
  - apply trans_head in TRq.
    destruct TRq as (? & ? & ? & ? & TRq & Eqq).
    eapply trans_bind_r; eauto; cbn.
    econstructor.
    rewrite Eqq; reflexivity.
  - apply trans_head in TRq.
    destruct TRq as (? & TRq & Eqq).
    eapply trans_bind_r; eauto; cbn.
    constructor.
    rewrite Eqq; reflexivity.
  - pose proof (trans_val_invT TRq); subst; easy.
Qed.

Lemma trans_para_inv :
  forall l p q r,
    trans l (p ∥ q) r ->
    (exists p', trans l p p' /\ r ≅ (p' ∥ q)) \/
      (exists q', trans l q q' /\ r ≅ (p ∥ q')) \/
      (exists p' q' a b,
          trans (comm a) p p' /\
            trans (comm b) q q' /\
            are_opposite a b /\
            l = tau /\
            r ≅ (p' ∥ q')).
Proof.
  intros * TR.
  rewrite unfold_para in TR.
  apply trans_brD_inv in TR as (x & TR).
  destruct x.
  - left.
    edestruct @trans_bind_inv; [apply TR | | ]; clear TR.
    destruct H as (NOTV & ? & TR & EQ); apply trans_head_inv in TR; easy.
    destruct H as (hdp & TRhdp & TR).
    destruct hdp; try easy.
    * apply trans_brS_inv in TR as (x & EQ & ->).
      eapply trans_ABr in TRhdp.
      eexists; split; eauto.
    * apply trans_vis_inv in TR as (x & EQ & ->).
      eapply trans_AVis in TRhdp.
      eexists; split; eauto.
  - right; left.
    edestruct @trans_bind_inv; [apply TR | | ]; clear TR.
    destruct H as (NOTV & ? & TR & EQ); apply trans_head_inv in TR; easy.
    destruct H as (hdq & TRhdq & TR).
    destruct hdq; try easy.
    * apply trans_brS_inv in TR as (x & EQ & ->).
      eapply trans_ABr in TRhdq.
      eexists; split; eauto.
    * apply trans_vis_inv in TR as (x & EQ & ->).
      eapply trans_AVis in TRhdq.
      eexists; split; eauto.
  - right; right.
    edestruct @trans_bind_inv; [apply TR | | ]; clear TR.
    destruct H as (NOTV & ? & TR & EQ); apply trans_head_inv in TR; easy.
    destruct H as (hdp & TRhdp & TR).
    edestruct @trans_bind_inv; [apply TR | | ]; clear TR.
    destruct H as (NOTV & ? & TR & EQ); apply trans_head_inv in TR; easy.
    destruct H as (hdq & TRhdq & TR).
    destruct hdp; try easy.
    exfalso; eapply stuckD_is_stuck; eassumption.
    destruct hdq; try easy.
    exfalso; eapply stuckD_is_stuck; eassumption.
    destruct e, e0, (are_opposite a a0) eqn:?.
    2:exfalso; eapply stuckD_is_stuck; eassumption.
    apply trans_step_inv in TR as [? ->].
    eapply trans_AVis in TRhdp.
    eapply trans_AVis in TRhdq.
    do 4 eexists.
    repeat split; eauto.
Qed.

Ltac trans_para_invT H :=
  apply trans_para_inv in H as
      [(?p' & ?TRp & ?EQ) |
        [(?q' & ?TRq & ?EQ) |
          (?p' & ?q' & ?a & ?b & ?TRp & ?TRq & ?Op & ? & ?EQ) ]]; subst.

(** ** parallel composition *)
Lemma ctx_para_t: binary_ctx para <= st eq.
Proof.
  apply Coinduction, by_Symmetry. apply binary_sym.
  intro R. apply (leq_binary_ctx para).
  intros * [F1 B1] * [F2 B2] ? * tr.
  trans_para_invT tr.
  - apply F1 in TRp as [? (? & tr & ? & ?)].
    do 2 eexists; split; [|split].
    apply trans_paraL; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx para).
    now apply (id_T (sb eq)).
    now apply (b_T (sb eq)).
    assumption.
  - apply F2 in TRq as [? (? & tr & ? & ?)].
    do 2 eexists; split; [|split].
    apply trans_paraR; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx para).
    now apply (b_T (sb eq)).
    now apply (id_T (sb eq)).
    assumption.
  - apply F1 in TRp as [? (? & trp & ? & <-)].
    apply F2 in TRq as [? (? & trq & ? & <-)].
    do 2 eexists; split; [|split].
    eapply trans_paraSynch; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx para); now apply (id_T (sb eq)).
    reflexivity.
Qed.

#[global] Instance para_t: forall R, Proper (st eq R ==> st eq R ==> st eq R) para :=
  binary_proper_t ctx_para_t.

#[global] Instance para_T f: forall R, Proper (sT eq f R ==> sT eq f R ==> sT eq f R) para :=
  binary_proper_T ctx_para_t.

Section Theory.

  Lemma plsC: forall (p q : ccs), p+q ~ q+p.
  Proof.
    apply brD2_commut.
  Qed.

  Lemma plsA (p q r : ccs): p+(q+r) ~ (p+q)+r.
  Proof.
    symmetry; apply brD2_assoc.
  Qed.

  Lemma pls0p (p : ccs) : 0 + p ~ p.
  Proof.
    apply brD2_stuckS_l.
  Qed.

  Lemma plsp0 (p : ccs) : p + 0 ~ p.
  Proof. now rewrite plsC, pls0p. Qed.

  Lemma plsidem (p : ccs) : p + p ~ p.
  Proof.
    apply brD2_idem.
  Qed.

  #[global] Instance are_opposite_sym : Symmetric are_opposite.
  Proof.
    unfold are_opposite, eqb_action, op; cbn.
    intros [] [] Op; intuition.
    all:rewrite eqb_sym; auto.
  Qed.

  Lemma paraC: forall (p q : ccs), p ∥ q ~ q ∥ p.
  Proof.
    coinduction ? CIH; symmetric using idtac.
    intros p q l r.
    eauto.
    simpl.
    intros p q ? ? tr.
    trans_para_invT tr.
    - do 2 eexists; split; [|split].
      eapply trans_paraR; eauto.
      rewrite EQ; auto.
      reflexivity.
    - do 2 eexists; split; [|split].
      eapply trans_paraL; eauto.
      rewrite EQ; auto.
      reflexivity.
    - do 2 eexists; split; [|split].
      eapply trans_paraSynch; eauto.
      symmetry; auto.
      rewrite EQ; auto.
      reflexivity.
  Qed.

  Lemma para0p : forall (p : ccs), 0 ∥ p ~ p.
  Proof.
    coinduction R CIH.
    intros.
    split.
    - intros l q tr.
      trans_para_invT tr; try now exfalso; eapply stuckS_is_stuck; eauto.
      do 2 eexists; split; eauto.
      rewrite EQ; auto.
    - intros l q tr.
      eexists.
      exists (0 ∥ q).
      split; eauto with trans.
      apply trans_paraR; eauto.
      cbn; auto.
  Qed.

  Lemma parap0 : forall (p : ccs), p ∥ 0 ~ p.
  Proof.
    intros; rewrite paraC; apply para0p.
  Qed.

  Lemma paraA : forall (p q r : ccs), p ∥ (q ∥ r) ~ (p ∥ q) ∥ r.
  Proof.
    coinduction ? CIH; intros.
    split.
    - intros l s tr.
      trans_para_invT tr.
      + do 2 eexists; split.
        do 2 apply trans_paraL; eauto.
        rewrite EQ; auto.
      + trans_para_invT TRq.
        * do 2 eexists; split.
          apply trans_paraL, trans_paraR; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          apply trans_paraR; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          eapply trans_paraSynch; eauto.
          eapply trans_paraR; eauto.
          rewrite EQ, EQ0; auto.
      + trans_para_invT TRq.
        * do 2 eexists; split.
          eapply trans_paraL, trans_paraSynch; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          eapply trans_paraSynch; eauto.
          eapply trans_paraL; eauto.
          rewrite EQ, EQ0; auto.
        * inv H.
    - intros l s tr; cbn.
      trans_para_invT tr.
      + trans_para_invT TRp.
        * do 2 eexists; split.
          apply trans_paraL; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          apply trans_paraR, trans_paraL; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          eapply trans_paraSynch; eauto.
          eapply trans_paraL; eauto.
          rewrite EQ, EQ0; auto.
      + do 2 eexists; split.
        eapply trans_paraR, trans_paraR; eauto.
        rewrite EQ; auto.
      + trans_para_invT TRp.
        * do 2 eexists; split.
          eapply trans_paraSynch; eauto.
          eapply trans_paraR; eauto.
          rewrite EQ, EQ0; auto.
        * do 2 eexists; split.
          eapply trans_paraR, trans_paraSynch; eauto.
          rewrite EQ, EQ0; auto.
        * inv H.
  Qed.

End Theory.

Notation parabang_ p q :=
  (brD4

     (* Communication by p *)
     (rp <- head p;;
      match rp with
      | ARet rp => match rp with end
      | ABr c kp => BrS c (fun i => parabang (kp i) q )
      | AVis e kp => Vis e (fun i => parabang (kp i) q)
      end)

     (* Communication by a fresh copy of q *)
     (rq <- head q;;
      match rq with
      | ARet rq => match rq with end
      | ABr c kq => BrS c (fun i => (parabang (para p (kq i)) q))
      | AVis e kq => Vis e (fun i => (parabang (para p (kq i)) q))
      end)

     (* Communication between p and a fresh copy of q *)
     (rp <- head p;;
      rq <- head q;;
      match rp, rq with
      | AVis ep kp, AVis eq kq =>
          match ep, kp, eq, kq with
          | Act a, kp, Act b, kq =>
              if are_opposite a b
              then
                Step (parabang (para (kp tt) (kq tt)) q)
              else
                stuckD
          end

      | _, _ => stuckD
      end)

     (* Communication between two fresh copies of q *)
     (rq1 <- head q;;
      rq2 <- head q;;
      match rq1, rq2 with
      | AVis eq1 kq1, AVis eq2 kq2 =>
          match eq1, kq1, eq2, kq2 with
          | Act a, kq1, Act b, kq2 =>
              if are_opposite a b
              then
                Step (parabang (para p (para (kq1 tt) (kq2 tt))) q)
              else
                stuckD
          end

      | _, _ => stuckD
      end))%ctree.

Lemma unfold_parabang : forall p q, parabang p q ≅ parabang_ p q.
Proof.
  intros.
  now step.
Qed.

Lemma unfold_bang : forall p, !p ≅ parabang_ p p.
Proof.
  intros; unfold bang. apply unfold_parabang.
Qed.

#[global] Instance parabang_equ :
  Proper (equ eq ==> equ eq ==> equ eq) parabang.
Proof.
  unfold Proper, respectful.
  coinduction R CIH.
  intros p1 p2 EQp q1 q2 EQq.
  rewrite 2 unfold_parabang.
  constructor.
  intros i.

  destruct i.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    inv eqp; auto.
    step; constructor; auto.
    step; constructor; auto.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    inv eqp; auto.
    step; constructor; intros ?.
    apply CIH; auto; rewrite EQp, H; reflexivity.
    step; constructor; intros ?.
    apply CIH; auto; rewrite EQp, H; reflexivity.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    upto_bind; [apply head_equ; auto | intros hdq1 hdq2 eqq].
    inv eqp; auto.
    inv eqq; auto.
    destruct e, e0, (are_opposite a a0); auto.
    step; constructor; intros ?.
    apply CIH; auto.
    rewrite H,H0; reflexivity.
  - upto_bind; [apply head_equ; auto | intros hdp1 hdp2 eqp].
    upto_bind; [apply head_equ; auto | intros hdq1 hdq2 eqq].
    inv eqp; auto.
    inv eqq; auto.
    destruct e, e0, (are_opposite a a0); auto.
    step; constructor; intros ?.
    apply CIH; auto.
    rewrite EQp, H,H0; reflexivity.
Qed.

Lemma trans_parabangL : forall p l p' q,
    trans l p p' ->
    trans l (parabang p q) (parabang p' q).
Proof.
  intros * TR.
  pose proof trans_head TR.
  rewrite unfold_parabang.
  apply trans_brD41.
  destruct l;
    repeat match goal with
           | h : Logic.ex _ |- _ => destruct h
           | h : Logic.and _ _ |- _ => destruct h
           end.
  - eapply trans_bind_r; eauto. cbn.
    rewrite H0; econstructor; reflexivity.
  - eapply trans_bind_r; eauto. cbn.
    rewrite H0; econstructor; reflexivity.
  - apply trans_val_invT in TR; subst; easy.
Qed.

Lemma trans_parabangR : forall p l q q',
    trans l q q' ->
    trans l (parabang p q) (parabang (p ∥ q') q).
Proof.
  intros * TR.
  pose proof trans_head TR.
  rewrite unfold_parabang.
  apply trans_brD42.
  destruct l;
    repeat match goal with
           | h : Logic.ex _ |- _ => destruct h
           | h : Logic.and _ _ |- _ => destruct h
           end.
  - eapply trans_bind_r; eauto. cbn.
    econstructor; rewrite H0; reflexivity.
  - eapply trans_bind_r; eauto. cbn.
    rewrite H0; econstructor; reflexivity.
  - apply trans_val_invT in TR; subst; easy.
Qed.

Lemma trans_parabangSL : forall a b p p' q q',
    are_opposite a b ->
    trans (comm a) p p' ->
    trans (comm b) q q' ->
    trans tau (parabang p q) (parabang (p' ∥ q') q).
Proof.
  intros * Op TR1 TR2.
  pose proof trans_head TR1 as (? & TRh1 & EQ1).
  pose proof trans_head TR2 as (? & TRh2 & EQ2).
  rewrite unfold_parabang.
  apply trans_brD43.
  eapply trans_bind_r; [apply TRh1 | ].
  eapply trans_bind_r; [apply TRh2 | ].
  cbn; rewrite Op.
  rewrite EQ1,EQ2.
  apply trans_step.
Qed.

Lemma trans_parabangSR : forall a b p q q' q'',
    are_opposite a b ->
    trans (comm a) q q' ->
    trans (comm b) q q'' ->
    trans tau (parabang p q) (parabang (p ∥ (q' ∥ q'')) q).
Proof.
  intros * Op TR1 TR2.
  pose proof trans_head TR1 as (? & TRh1 & EQ1).
  pose proof trans_head TR2 as (? & TRh2 & EQ2).
  rewrite unfold_parabang.
  apply trans_brD44.
  eapply trans_bind_r; [apply TRh1 | ].
  eapply trans_bind_r; [apply TRh2 | ].
  cbn; rewrite Op.
  rewrite EQ1,EQ2.
  apply trans_step.
Qed.

Lemma trans_parabang_inv : forall l p q r,
    trans l (parabang p q) r ->
    (exists p', trans l p p' /\ r ≅ parabang p' q) \/
      (exists q', trans l q q' /\ r ≅ parabang (p ∥ q') q) \/
      (exists a b p' q', trans (comm a) p p' /\
                      trans (comm b) q q' /\
                      are_opposite a b /\
                      l = tau /\
                      r ≅ parabang (p' ∥ q') q) \/
      (exists a b q' q'', trans (comm a) q q' /\
                       trans (comm b) q q'' /\
                       are_opposite a b /\
                       l = tau /\
                       r ≅ parabang (p ∥ (q' ∥ q'')) q).
Proof.
  intros * TR.
  rewrite unfold_parabang in TR.
  apply trans_brD_inv in TR as [[]  TR].
  - left.
    apply trans_bind_inv in TR.
    destruct TR as [(NV & ? & TR & ?) | (? & TR1 & TR2)]; [apply trans_head_inv in TR; easy|].
    destruct x; try easy.
    apply trans_brS_inv in TR2 as (x & EQ & ->).
    pose proof trans_ABr TR1 x.
    eauto.
    apply trans_vis_inv in TR2 as (x & EQ & ->).
    pose proof trans_AVis TR1 (i := x).
    eauto.
  - right; left.
    apply trans_bind_inv in TR.
    destruct TR as [(NV & ? & TR & ?) | (? & TR1 & TR2)]; [apply trans_head_inv in TR; easy|].
    destruct x; try easy.
    apply trans_brS_inv in TR2 as (x & EQ & ->).
    pose proof trans_ABr TR1 x.
    eauto.
    apply trans_vis_inv in TR2 as (x & EQ & ->).
    pose proof trans_AVis TR1 (i := x).
    eauto.
  - right; right; left.
    apply trans_bind_inv in TR.
    destruct TR as [(NV & ? & TR & ?) | (? & TR1 & TR2)]; [apply trans_head_inv in TR; easy|].
    apply trans_bind_inv in TR2.

    destruct TR2 as [(NV & ? & TR & ?) | (? & TR2 & TR3)]; [apply trans_head_inv in TR; easy|].
    destruct x, x0; try easy; try now (exfalso; eapply stuckD_is_stuck; eauto).
    destruct e, e0, (are_opposite a a0) eqn:?; try easy; try now (exfalso; eapply stuckD_is_stuck; eauto).
    apply trans_step_inv in TR3 as (? & ->).
    pose proof trans_AVis TR1 (i := tt).
    pose proof trans_AVis TR2 (i := tt).
    eauto 10.
  - right; right; right.
    apply trans_bind_inv in TR.
    destruct TR as [(NV & ? & TR & ?) | (? & TR1 & TR2)]; [apply trans_head_inv in TR; easy|].
    apply trans_bind_inv in TR2.
    destruct TR2 as [(NV & ? & TR & ?) | (? & TR2 & TR3)]; [apply trans_head_inv in TR; easy|].
    destruct x, x0; try easy; try now (exfalso; eapply stuckD_is_stuck; eauto).
    destruct e, e0, (are_opposite a a0) eqn:?; try easy; try now (exfalso; eapply stuckD_is_stuck; eauto).
    apply trans_step_inv in TR3 as (? & ->).
    pose proof trans_AVis TR1 (i := tt).
    pose proof trans_AVis TR2 (i := tt).
    eauto 10.
Qed.

Ltac trans_parabang_invT TR :=
  apply trans_parabang_inv in TR as
      [(?p' & ?TRp' & ?EQ) |
        [(?q' & ?TRq' & ?EQ) |
          [(?a & ?b & ?p' & ?q' & ?TRp' & ?TRq' & ?Op & ?EQl & ?EQ) |
            (?a & ?b & ?q' & ?q'' & ?TRq' & ?TRq'' & ?Op & ?EQl & ?EQ)]]]; subst.

Ltac pbL := apply trans_parabangL.
Ltac pbR := apply trans_parabangR.
Ltac pbSL := eapply trans_parabangSL.
Ltac pbSR := eapply trans_parabangSR.

Ltac pL := apply trans_paraL.
Ltac pR := apply trans_paraR.
Ltac pS := eapply trans_paraSynch.

Lemma para_parabang : forall p q r,
    parabang (p ∥ q) r ~ p ∥ parabang q r.
Proof.
  coinduction ? CIH.
  intros; split.
  - intros l s TR.
    trans_parabang_invT TR.
    + trans_para_invT TRp'.
      * do 2 eexists; split.
        pL; eauto.
        rewrite EQ, EQ0; auto.
      * do 2 eexists; split.
        pR;pbL; eauto.
        rewrite EQ,EQ0; auto.
      * do 2 eexists; split.
        pS; eauto.
        pbL; eauto.
        rewrite EQ,EQ0; auto.
    + do 2 eexists; split.
      pR; pbR; eauto.
      rewrite EQ, !CIH, paraA; auto.

    + trans_para_invT TRp'.
      * do 2 eexists; split.
        pS; eauto.
        pbR; eauto.
        rewrite EQ,EQ0, !CIH, !paraA; eauto.
      * do 2 eexists; split.
        pR; pbSL; eauto.
        rewrite EQ,EQ0, !CIH, !paraA; eauto.
      * easy.

    + do 2 eexists; split.
      pR; pbSR; eauto.
      rewrite EQ, !CIH, !paraA; eauto.

  - intros l s TR.
    trans_para_invT TR.
    + do 2 eexists; split.
      pbL;pL; eauto.
      cbn; rewrite EQ; auto.

    + trans_parabang_invT TRq.
      * do 2 eexists; split.
        pbL;pR; eauto.
        cbn; rewrite EQ, EQ0; auto.
      * do 2 eexists; split.
        pbR; eauto.
        cbn; rewrite EQ,EQ0,!CIH,!paraA; auto.
      * do 2 eexists; split.
        pbSL; eauto.
        pR; eauto.
        cbn; rewrite EQ,EQ0,!CIH,!paraA; auto.
      * do 2 eexists; split.
        pbSR; eauto.
        cbn; rewrite EQ,EQ0,!CIH,!paraA; auto.

    + trans_parabang_invT TRq.
      * do 2 eexists; split.
        pbL;pS; eauto.
        cbn; rewrite EQ, EQ0; auto.
      * do 2 eexists; split.
        pbSL; eauto.
        pL; eauto.
        cbn; rewrite EQ,EQ0,!CIH,!paraA; auto.
      * easy.
      * easy.
Qed.

Lemma ctx_parabang_t: binary_ctx parabang <= st eq.
Proof.
  apply Coinduction, by_Symmetry. apply binary_sym.
  intro R. apply (leq_binary_ctx parabang).
  intros * [F1 B1] * [F2 B2] ? * tr.
  trans_parabang_invT tr.
  - apply F1 in TRp' as [? (? & tr & ? & ?)].
    do 2 eexists; split; [|split].
    pbL; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx parabang).
    now apply (id_T (sb eq)).
    now apply (b_T (sb eq)).
    assumption.
  - apply F2 in TRq' as [? (? & tr & ? & ?)].
    do 2 eexists; split; [|split].
    pbR; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx parabang).
    apply (fT_T ctx_para_t).
    apply (in_binary_ctx para).
    now apply (b_T (sb eq)).
    now apply (id_T (sb eq)).
    now apply (b_T (sb eq)).
    assumption.
  - apply F1 in TRp' as [? (? & trp & ? & <-)].
    apply F2 in TRq' as [? (? & trq & ? & <-)].
    do 2 eexists; split; [|split].
    pbSL; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx parabang).
    apply (fT_T ctx_para_t).
    apply (in_binary_ctx para).
    now apply (id_T (sb eq)).
    now apply (id_T (sb eq)).
    now apply (b_T (sb eq)).
    reflexivity.
  - apply F2 in TRq' as  [? (? & trq' & ? & <-)].
    apply F2 in TRq'' as  [? (? & trq'' & ? & <-)].
    do 2 eexists; split; [|split].
    pbSR; eauto.
    rewrite EQ.
    apply (fTf_Tf (sb eq)). apply (in_binary_ctx parabang).
    apply (fT_T ctx_para_t), (in_binary_ctx para).
    now apply (b_T (sb eq)).
    apply (fT_T ctx_para_t), (in_binary_ctx para).
    now apply (id_T (sb eq)).
    now apply (id_T (sb eq)).
    now apply (b_T (sb eq)).
    reflexivity.
Qed.

#[global] Instance parabang_t: forall R, Proper (st eq R ==> st eq R ==> st eq R) parabang := binary_proper_t ctx_parabang_t.
#[global] Instance parabang_T f: forall R, Proper (sT eq f R ==> sT eq f R ==> sT eq f R) parabang := binary_proper_T ctx_parabang_t.

Lemma parabang_aux : forall p q,
    parabang (p ∥ q) q ~ parabang p q.
Proof.
  coinduction ? CIH.
  split.
  - intros l r TR.
    trans_parabang_invT TR.

    + trans_para_invT TRp'.
      * do 2 eexists; split.
        pbL; eauto.
        rewrite EQ,EQ0; eauto.
      * do 2 eexists; split.
        pbR; eauto.
        rewrite EQ,EQ0; eauto.
      * do 2 eexists; split.
        pbSL; eauto.
        rewrite EQ,EQ0; eauto.

    + do 2 eexists; split.
      pbR; eauto.
      rewrite EQ.
      rewrite <- paraA.
      rewrite (paraC q).
      rewrite paraA.
      auto.

    + trans_para_invT TRp'.
      * do 2 eexists; split.
        pbSL; eauto.
        rewrite EQ, EQ0.
        rewrite <- paraA.
        rewrite (paraC q).
        rewrite paraA.
        auto.
      * do 2 eexists; split.
        pbSR; eauto.
        rewrite EQ, EQ0.
        rewrite <- paraA; auto.
      * easy.

    + do 2 eexists; split.
      pbSR; eauto.
      rewrite EQ.
      rewrite <- paraA.
      rewrite (paraC q).
      rewrite ! paraA.
      auto.

  - intros l p' TR.
    trans_parabang_invT TR.

    + do 2 eexists; split.
      pbL;pL; eauto.
      cbn; rewrite EQ; eauto.

    + do 2 eexists; split.
      pbL;pR; eauto.
      cbn; rewrite EQ; eauto.

    + do 2 eexists; split.
      pbL;pS; eauto.
      cbn; rewrite EQ; eauto.

    + do 2 eexists; split.
      pbSL; eauto.
      pR; eauto.
      cbn; rewrite EQ, !paraA; eauto.

Qed.

Lemma parabang_eq : forall p q,
    parabang p q ~ p ∥ !q.
Proof.
  coinduction ? CIH.
  intros p q; split.

  - intros l p' TR.
    trans_parabang_invT TR.

    + do 2 eexists; split.
      pL; eauto.
      rewrite EQ; eauto.

    + do 2 eexists; split.
      pR; pbL; eauto.
      rewrite EQ; eauto.
      rewrite para_parabang; auto.

    + do 2 eexists; split.
      pS; eauto.
      pbL; eauto.
      rewrite EQ; eauto.
      rewrite para_parabang; auto.

    + do 2 eexists; split.
      pR; pbSL; eauto.
      rewrite EQ; eauto.
      rewrite para_parabang; auto.

  - intros l p' TR.
    trans_para_invT TR.

    + do 2 eexists; split.
      pbL; eauto.
      cbn; rewrite EQ; eauto.

    + trans_parabang_invT TRq.
      * do 2 eexists; split.
        pbR; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite !CIH, !paraA; eauto.
      * do 2 eexists; split.
        pbR; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite (paraC q), parabang_aux.
        rewrite !CIH, !paraA; eauto.
      * do 2 eexists; split.
        pbSR; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite !CIH, !paraA; eauto.
      * do 2 eexists; split.
        pbSR; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite (paraC q), parabang_aux.
        rewrite !CIH, !paraA; eauto.

    + trans_parabang_invT TRq.
      * do 2 eexists; split.
        pbSL; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite !CIH, !paraA; eauto.
      * do 2 eexists; split.
        pbSL; eauto.
        cbn; rewrite EQ,EQ0; eauto.
        rewrite (paraC q), parabang_aux.
        rewrite !CIH, !paraA; eauto.
      * easy.
      * easy.
Qed.

Lemma unfold_bang' : forall p,
    !p ~ !p ∥ p.
Proof.
  intros; unfold bang at 1.
  rewrite parabang_eq. rewrite paraC; reflexivity.
Qed.

Import CCSNotations.
Open Scope term_scope.

Fixpoint model (t : term) : ccs :=
	match t with
	| 0      => nil
	| a · P  => prefix a (model P)
	| TauT P => Step (model P)
	| P ∥ Q  => para (model P) (model Q)
	| P ⊕ Q  => plus (model P) (model Q)
	| P ∖ c  => new c (model P)
	| !P    => bang (model P)
	end.

Module DenNotations.

  (* Notations for patterns *)
  Notation "'synchP' e" := (inl1 e) (at level 10).
  Notation "'actP' e" := (inr1 (inl1 e)) (at level 10).
  Notation "'deadP' e" :=  (inr1 (inr1 e)) (at level 10).

  Notation "⟦ t ⟧" := (model t).
  (* Notation "P '⊢' a '→ccs' Q" := (step_ccs P a Q) (at level 50). *)
  (* Notation "P '⊢' a '→sem' Q" := (step_sem P a Q) (at level 50). *)

End DenNotations.

Import DenNotations.


(** * Bicolano: Semantic domains *)

(* <Insert License Here>

    $Id: Domain.v 69 2006-03-06 20:16:11Z davidpichardie $ *)

(** Formalization of Java semantic domain.
 Based on The "Java (TM) Virtual Machine Specification, Second Edition,
  Tim Lindholm, Frank Yellin"

 @author David Pichardie, ...  *)
(* Hendra : - Modified to suit DEX program (removed operand stack).
            - Removed reference comparison
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_Program.
Require Export Numeric.
Require Export List.
Open Scope Z_scope.

(** All semantic domains and basic operation are encapsulated in a module signature *)

Module Type DEX_SEMANTIC_DOMAIN.

 (** We depend on the choices done for program data structures *)
 Declare Module DEX_Prog : DEX_PROGRAM. Import DEX_Prog.

 Declare Module Byte  : NUMERIC with Definition power := 7%nat.
 Declare Module Short : NUMERIC with Definition power := 15%nat.
 Declare Module Int   : NUMERIC with Definition power := 31%nat.

 (** conversion *)
 Parameter b2i : Byte.t -> Int.t.
 Parameter s2i : Short.t -> Int.t.
 Parameter i2b : Int.t -> Byte.t.
 Parameter i2s : Int.t -> Short.t.
 Parameter i2bool : Int.t -> Byte.t.

 Inductive DEX_num : Set :=
   | I : Int.t -> DEX_num
   | B : Byte.t -> DEX_num
   | Sh : Short.t -> DEX_num.

 (** Location is the domain of adresses in the heap *)
 Parameter DEX_Location : Set.
 Parameter DEX_Location_dec : forall loc1 loc2:DEX_Location,{loc1=loc2}+{~loc1=loc2}.

 Inductive DEX_value : Set :=
   | Num : DEX_num -> DEX_value
   | Ref: DEX_Location -> DEX_value
   | Null : DEX_value.

 Definition init_value (t:DEX_type) : DEX_value :=
    match t with
     | DEX_PrimitiveType _ => Num (I (Int.const 0))
     | DEX_ReferenceType _ => Null
    end.

 Definition init_field_value (f:DEX_Field) : DEX_value :=
   match DEX_FIELD.initValue f with
    | DEX_FIELD.Int z => Num (I (Int.const z))
    | DEX_FIELD.NULL => Null
    | DEX_FIELD.UNDEF => init_value (DEX_FIELDSIGNATURE.type (DEX_FIELD.signature f))
  end.

 (** Domain of local variables *)
 Module Type DEX_REGISTERS.
   Parameter t : Type.
   Parameter get : t-> DEX_Reg -> option DEX_value.
   Parameter update : t -> DEX_Reg -> DEX_value -> t.
   Parameter dom : t -> list DEX_Reg.
   Parameter get_update_new : forall l x v, get (update l x v) x = Some v.
   Parameter get_update_old : forall l x y v,
     x<>y -> get (update l x v) y = get l y.
 End DEX_REGISTERS.
 Declare Module DEX_Registers : DEX_REGISTERS.

 Parameter listreg2regs : DEX_Registers.t -> nat -> list DEX_Reg -> DEX_Registers.t.

(* 290415 - Some Notes
- According to verified DEX bytecode, every registers have
  to have a value before used. This means we can safely assume
  that we don't need the update to be option anymore because
  the only possible case where it updates empty value is when
  the source is empty, which has been taken care by the assumption
- The special register ret and ex are assigned the number
  65536 and 65537 respectively (in binary) because we know
  that the maximum number of registers is 65535.
*)

 Module Type DEX_HEAP.
   Parameter t : Type.

   Inductive DEX_AdressingMode : Set :=
     (*| StaticField : FieldSignature -> AdressingMode*)
     | DEX_DynamicField : DEX_Location -> DEX_FieldSignature -> DEX_AdressingMode
     (*| ArrayElement : Location -> Z -> AdressingMode*).

   Inductive DEX_LocationType : Type :=
     | DEX_LocationObject : DEX_ClassName -> DEX_LocationType
     (*| LocationArray : Int.t -> type -> Method*PC -> LocationType*).
   (** (LocationArray length element_type) *)

   Parameter get : t -> DEX_AdressingMode -> option DEX_value.
   Parameter update : t -> DEX_AdressingMode -> DEX_value -> t.
   Parameter typeof : t -> DEX_Location -> option DEX_LocationType.
     (** typeof h loc = None -> no object, no array allocated at location loc *)
   Parameter new : t -> DEX_Program -> DEX_LocationType -> option (DEX_Location * t).
     (** program is required to compute the size of the allocated element, i.e. to know
        the Class associated with a ClassName  *)

   (** Compatibility between a heap and an adress *)
   Inductive Compat (h:t) : DEX_AdressingMode -> Prop :=
     (*| CompatStatic : forall f,
         Compat h (StaticField f)*)
     | CompatObject : forall cn loc f,
         typeof h loc = Some (DEX_LocationObject cn) ->
         Compat h (DEX_DynamicField loc f)
   (*  | CompatArray : forall length tp loc i a,
         0 <= i < Int.toZ length ->
         typeof h loc = Some (LocationArray length tp a) ->
         Compat h (ArrayElement loc i)*).

   Parameter get_update_same : forall h am v, Compat h am ->  get (update h am v) am = Some v.
   Parameter get_update_old : forall h am1 am2 v, am1<>am2 -> get (update h am1 v) am2 = get h am2.
   Parameter get_uncompat : forall h am, ~ Compat h am -> get h am = None.

   Parameter typeof_update_same : forall h loc am v,
     typeof (update h am v) loc = typeof h loc.

   Parameter new_fresh_location : forall (h:t) (p:DEX_Program)
      (lt:DEX_LocationType) (loc:DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     typeof h loc = None.

   Parameter new_typeof : forall (h:t) (p:DEX_Program) (lt:DEX_LocationType) (loc:DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     typeof h' loc = Some lt.

   Parameter new_typeof_old : forall (h:t) (p:DEX_Program) (lt:DEX_LocationType)
      (loc loc':DEX_Location) (h':t),
     new h p lt = Some (loc,h') ->
     loc <> loc' ->
     typeof h' loc' = typeof h loc'.

   Parameter new_defined_object_field : forall (h:t) (p:DEX_Program) (cn:DEX_ClassName)
      (fs:DEX_FieldSignature) (f:DEX_Field) (loc:DEX_Location) (h':t),
     new h p (DEX_LocationObject cn) = Some (loc,h') ->
     is_defined_field p cn fs f ->
     get h' (DEX_DynamicField loc fs) = Some (init_field_value f).

   Parameter new_undefined_object_field : forall (h:t) (p:DEX_Program) (cn:DEX_ClassName)
      (fs:DEX_FieldSignature) (loc:DEX_Location) (h':t),
     new h p (DEX_LocationObject cn) = Some (loc,h') ->
     ~ defined_field p cn fs ->
     get h' (DEX_DynamicField loc fs) = None.

  Parameter new_object_no_change :
     forall (h:t) (p:DEX_Program) (cn:DEX_ClassName) (loc:DEX_Location) (h':t) (am:DEX_AdressingMode),
     new h p (DEX_LocationObject cn) = Some (loc,h') ->
     (forall (fs:DEX_FieldSignature), am <> (DEX_DynamicField loc fs)) ->
     get h' am = get h am.

(*  Parameter new_valid_array_index : forall (h:t) (p:Program) (length:Int.t) (tp:type) a (i:Z) (loc:Location) (h':t),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     0 <= i < Int.toZ length ->
     get h' (ArrayElement loc i) = Some (init_value tp).

  Parameter new_unvalid_array_index : forall (h:t) (p:Program) (length:Int.t) (tp:type) a (i:Z) (loc:Location) (h':t),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     ~ 0 <= i < Int.toZ length ->
     get h' (ArrayElement loc i) = None.

  Parameter new_array_no_change :
     forall (h:t) (p:Program) (length:Int.t) (tp:type) a (loc:Location) (h':t) (am:AdressingMode),
     new h p (LocationArray length tp a) = Some (loc,h') ->
     (forall (i:Z), am <> (ArrayElement loc i)) ->
     get h' am = get h am.*)
 End DEX_HEAP.
 Declare Module DEX_Heap : DEX_HEAP.

  Inductive DEX_ReturnVal : Set :=
   | Normal : option DEX_value -> DEX_ReturnVal.

 (** Domain of frames *)
 Module Type DEX_FRAME.
   Inductive t : Type :=
      make : DEX_Method -> DEX_PC -> DEX_Registers.t -> t.
 End DEX_FRAME.
 Declare Module DEX_Frame : DEX_FRAME.

 (** Domain of call stacks *)
 Module Type DEX_CALLSTACK.
   Definition t : Type := list DEX_Frame.t.
 End DEX_CALLSTACK.
 Declare Module DEX_CallStack : DEX_CALLSTACK.

 (** Domain of states *)
 Module Type DEX_STATE.
   Inductive t : Type :=
      normal : DEX_Heap.t -> DEX_Frame.t -> DEX_CallStack.t -> t.
   Definition get_sf (s:t) : DEX_CallStack.t :=
     match s with
       normal _ _ sf => sf
     end.
   Definition get_m (s:t) : DEX_Method :=
     match s with
       normal _ (DEX_Frame.make m _ _)_ => m
     end.
 End DEX_STATE.
 Declare Module DEX_State : DEX_STATE.

 (** Some notations *)
 Notation St := DEX_State.normal.
 Notation Fr := DEX_Frame.make.

  Inductive isReference : DEX_value -> Prop :=
  | isReference_null : isReference Null
  | isReference_ref : forall loc, isReference (Ref loc).

  (** compatibility between ValKind and value *)
  Inductive compat_ValKind_value : DEX_ValKind -> DEX_value -> Prop :=
    | compat_ValKind_value_ref : forall v,
        isReference v -> compat_ValKind_value DEX_Aval v
    | compat_ValKind_value_int : forall n,
        compat_ValKind_value DEX_Ival (Num (I n)).

  (** [assign_compatible_num source target] holds if a numeric value [source] can be
    assigned to a variable of type [target]. This point is not clear in the JVM spec. *)
  Inductive assign_compatible_num : DEX_num -> DEX_primitiveType -> Prop :=
   | assign_compatible_int_int : forall i, assign_compatible_num (I i) DEX_INT
   | assign_compatible_short_int : forall sh, assign_compatible_num (Sh sh) DEX_INT
   | assign_compatible_byte_int : forall b, assign_compatible_num (B b) DEX_INT
   | assign_compatible_short_short : forall sh, assign_compatible_num (Sh sh) DEX_SHORT
   | assign_compatible_byte_byte : forall b, assign_compatible_num (B b) DEX_BYTE
   | assign_compatible_byte_boolean : forall b, assign_compatible_num (B b) DEX_BOOLEAN.

  (** [assign_compatible h source target] holds if a value [source] can be
    assigned to a variable of type [target] *)
  Inductive assign_compatible (p:DEX_Program) (h:DEX_Heap.t) : DEX_value -> DEX_type -> Prop :=
   | assign_compatible_null : forall t, assign_compatible p h Null (DEX_ReferenceType t)
   | assign_compatible_ref_object_val : forall (loc:DEX_Location) (t:DEX_refType) (cn:DEX_ClassName),
       DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
       compat_refType p (DEX_ClassType cn) t ->
       assign_compatible p h (Ref loc) (DEX_ReferenceType t)
   | assign_compatible_num_val : forall (n:DEX_num) (t:DEX_primitiveType),
       assign_compatible_num n t -> assign_compatible p h (Num n) (DEX_PrimitiveType t).

  Definition SemCompInt (cmp:DEX_CompInt) (z1 z2: Z) : Prop :=
    match cmp with
      DEX_EqInt =>  z1=z2
    | DEX_NeInt => z1<>z2
    | DEX_LtInt => z1<z2
    | DEX_LeInt => z1<=z2
    | DEX_GtInt => z1>z2
    | DEX_GeInt => z1>=z2
    end.

  Definition SemBinopInt (op:DEX_BinopInt) (i1 i2:Int.t) : Int.t :=
    match op with
    | DEX_AddInt => Int.add i1 i2
    | DEX_AndInt => Int.and i1 i2
    | DEX_DivInt => Int.div i1 i2
    | DEX_MulInt => Int.mul i1 i2
    | DEX_OrInt => Int.or i1 i2
    | DEX_RemInt => Int.rem i1 i2
    | DEX_ShlInt => Int.shl i1 i2
    | DEX_ShrInt => Int.shr i1 i2
    | DEX_SubInt => Int.sub i1 i2
    | DEX_UshrInt => Int.ushr i1 i2
    | DEX_XorInt => Int.xor i1 i2
    end.

End DEX_SEMANTIC_DOMAIN.


Require Import Echo1 Stack3A HoareDef SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.
Require Import HTactics ProofMode IPM.
Require Import OpenDef STB.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section REFINE.
  Context `{Σ: GRA.t}.
  Context `{@GRA.inG stkRA Σ}.

  Let W: Type := Any.t * Any.t.

  Let wf: _ -> W -> Prop := fun (_: unit) _ => True.

  Variable frds0 frds1: Sk.t -> list string.
  Hypothesis FRDS: forall sk, List.incl (frds1 sk) (frds0 sk).

  Theorem correct:
    refines2 [KMod.transl_src frds0 Echo1.KEcho] [KMod.transl_src frds1 Echo1.KEcho].
  Proof.
    eapply adequacy_local2. econs; ss. i.
    econstructor 1 with (wf:=wf) (le:=top2); ss.
    2: { esplits; et. ss. }
    econs; ss.
    { init. rewrite ! my_if_same. unfold echo_body, body_to_src.
      steps. unfold unwrapU. steps. des_ifs; steps. des_ifs; steps.
      unfold ccallN. steps. unfold unwrapN. des_ifs; steps.
      des_ifs; steps. red. esplits; et. }
    econs; ss.
    { init. unfold sumbool_to_bool, body_to_src. des_ifs.
      { unfold cfunN, input_body. steps.
        unfold unwrapN, ccallU, ccallN, unwrapU, unwrapN.
        des_ifs; steps. des_ifs; steps. force_r. esplits; et.
        steps. des_ifs; steps. des_ifs; steps.
        { red. esplits; et. }
        steps. des_ifs; steps.
        red. esplits; et.
      }
      { exfalso. eapply n. ss. des; auto. right.
        eapply in_map_iff in i. des; subst. eapply in_map. eapply FRDS. et. }
      { steps. }
      { steps. }
    }
    econs; ss.
    { init. unfold sumbool_to_bool, body_to_src. des_ifs.
      { unfold cfunN, output_body. steps.
        unfold unwrapN, ccallU, ccallN, unwrapU, unwrapN.
        des_ifs; steps. des_ifs; steps.
        { red. esplits; et. }
        steps. des_ifs; steps.
        des_ifs; steps. red. esplits; et.
      }
      { exfalso. eapply n. ss. des; auto. right.
        eapply in_map_iff in i. des; subst. eapply in_map. eapply FRDS. et. }
      { steps. }
      { steps. }
    }
    Unshelve. all: ss. all: exact 0.
  Qed.
End REFINE.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Export Maps.
Require Import Events.
Require Import Globalenvs.

Require Import mem_lemmas. (*for mem_forward*)
Require Import semantics.
Require Import effect_semantics.

Require Import Csharpminor.
Require Import Csharpminor_coop.

Require Import BuiltinEffects.

Lemma EmptyEffect_allocvariables: forall L e m e' m'
      (ALLOC: alloc_variables e m L e' m'),
  Mem.unchanged_on (fun b ofs => EmptyEffect b ofs = false) m m'.
Proof. intros L.
  induction L; simpl; intros; inv ALLOC.
    apply Mem.unchanged_on_refl.
  specialize (IHL _ _ _ _ H6). clear H6.
  eapply (unchanged_on_trans _ m1).
    eapply EmptyEffect_alloc; eassumption.
    eassumption.
  eapply alloc_forward; eassumption.
Qed.

Section CSHARPMINOR_EFF.
Variable hf : I64Helpers.helper_functions.

Inductive csharpmin_effstep (g: Csharpminor.genv):  (block -> Z -> bool) ->
            CSharpMin_core -> mem -> CSharpMin_core -> mem -> Prop :=

  | csharpmin_effstep_skip_seq: forall f s k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f Sskip (Kseq s k) e le) m
        (CSharpMin_State f s k e le) m
  | csharpmin_effstep_skip_block: forall f k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f Sskip (Kblock k) e le) m
        (CSharpMin_State f Sskip k e le) m
  | csharpmin_effstep_skip_call: forall f k e le m m',
      is_call_cont k ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      csharpmin_effstep g (FreelistEffect m (blocks_of_env e)) (CSharpMin_State f Sskip k e le) m
        (CSharpMin_Returnstate Vundef k) m'

  | csharpmin_effstep_set: forall f id a k e le m v,
      eval_expr g e le m a v ->
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sset id a) k e le) m
        (CSharpMin_State f Sskip k e (PTree.set id v le)) m

  | csharpmin_effstep_store: forall f chunk addr a k e le m vaddr v m',
      eval_expr g e le m addr vaddr ->
      eval_expr g e le m a v ->
      Mem.storev chunk m vaddr v = Some m' ->
      csharpmin_effstep g (StoreEffect vaddr (encode_val chunk v))
        (CSharpMin_State f (Sstore chunk addr a) k e le) m
        (CSharpMin_State f Sskip k e le) m'

  | csharpmin_effstep_call: forall f optid sig a bl k e le m vf vargs fd,
      eval_expr g e le m a vf ->
      eval_exprlist g e le m bl vargs ->
      Genv.find_funct g vf = Some fd ->
      funsig fd = sig ->
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Scall optid sig a bl) k e le) m
        (CSharpMin_Callstate fd vargs (Kcall optid f e le k)) m

  | csharpmin_effstep_builtin: forall f optid ef bl k e le m vargs t vres m',
      eval_exprlist g e le m bl vargs ->
      external_call ef g vargs m t vres m' ->
      ~ observableEF hf ef ->
      csharpmin_effstep g (BuiltinEffect g ef vargs m)
         (CSharpMin_State f (Sbuiltin optid ef bl) k e le) m
         (CSharpMin_State f Sskip k e (Cminor.set_optvar optid vres le)) m'

  | csharpmin_effstep_seq: forall f s1 s2 k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sseq s1 s2) k e le) m
        (CSharpMin_State f s1 (Kseq s2 k) e le) m

  | csharpmin_effstep_ifthenelse: forall f a s1 s2 k e le m v b,
      eval_expr g e le m a v ->
      Val.bool_of_val v b ->
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sifthenelse a s1 s2) k e le) m
        (CSharpMin_State f (if b then s1 else s2) k e le) m

  | csharpmin_effstep_loop: forall f s k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sloop s) k e le) m
        (CSharpMin_State f s (Kseq (Sloop s) k) e le) m

  | csharpmin_effstep_block: forall f s k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sblock s) k e le) m
        (CSharpMin_State f s (Kblock k) e le) m

  | csharpmin_effstep_exit_seq: forall f n s k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sexit n) (Kseq s k) e le) m
        (CSharpMin_State f (Sexit n) k e le) m
  | csharpmin_effstep_exit_block_0: forall f k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sexit O) (Kblock k) e le) m
        (CSharpMin_State f Sskip k e le) m
  | csharpmin_effstep_exit_block_S: forall f n k e le m,
      csharpmin_effstep g EmptyEffect
        (CSharpMin_State f (Sexit (S n)) (Kblock k) e le) m
        (CSharpMin_State f (Sexit n) k e le) m

  | csharpmin_effstep_switch: forall f a cases k e le m n,
      eval_expr g e le m a (Vint n) ->
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sswitch a cases) k e le) m
        (CSharpMin_State f (seq_of_lbl_stmt (select_switch n cases)) k e le) m

  | csharpmin_effstep_return_0: forall f k e le m m',
      Mem.free_list m (blocks_of_env e) = Some m' ->
      csharpmin_effstep g (FreelistEffect m (blocks_of_env e)) (CSharpMin_State f (Sreturn None) k e le) m
        (CSharpMin_Returnstate Vundef (call_cont k)) m'
  | csharpmin_effstep_return_1: forall f a k e le m v m',
      eval_expr g e le m a v ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      csharpmin_effstep g (FreelistEffect m (blocks_of_env e)) (CSharpMin_State f (Sreturn (Some a)) k e le) m
        (CSharpMin_Returnstate v (call_cont k)) m'
  | csharpmin_effstep_label: forall f lbl s k e le m,
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Slabel lbl s) k e le) m
        (CSharpMin_State f s k e le) m

  | csharpmin_effstep_goto: forall f lbl k e le m s' k',
      find_label lbl f.(fn_body) (call_cont k) = Some(s', k') ->
      csharpmin_effstep g EmptyEffect (CSharpMin_State f (Sgoto lbl) k e le) m
        (CSharpMin_State f s' k' e le) m

  | csharpmin_effstep_internal_function: forall f vargs k m m1 e le,
      list_norepet (map fst f.(fn_vars)) ->
      list_norepet f.(fn_params) ->
      list_disjoint f.(fn_params) f.(fn_temps) ->
      alloc_variables empty_env m (fn_vars f) e m1 ->
      bind_parameters f.(fn_params) vargs (create_undef_temps f.(fn_temps)) = Some le ->
      csharpmin_effstep g EmptyEffect
        (CSharpMin_Callstate (Internal f) vargs k) m
        (CSharpMin_State f f.(fn_body) k e le) m1

(*All external calls in this language at handled by atExternal
  | csharpmin_effstep_external_function: forall ef vargs k m t vres m',
      external_call ef g vargs m t vres m' ->
      csharpmin_effstep g EmptyEffect (CSharpMin_Callstate (External ef) vargs k) m
         (CSharpMin_Returnstate vres k) m' *)

  | csharpmin_effstep_return: forall v optid f e le k m,
      csharpmin_effstep g EmptyEffect (CSharpMin_Returnstate v (Kcall optid f e le k)) m
        (CSharpMin_State f Sskip k e (Cminor.set_optvar optid v le)) m.

Lemma csharpminstep_effax1: forall (M : block -> Z -> bool) g c m c' m'
      (H: csharpmin_effstep g M c m c' m'),
       corestep (csharpmin_coop_sem hf) g c m c' m' /\
       Mem.unchanged_on (fun (b : block) (ofs : Z) => M b ofs = false) m m'.
Proof.
intros.
  induction H.
  split. unfold corestep, coopsem; simpl. econstructor.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply StoreEffect_Storev; eassumption.
  split. unfold corestep, coopsem; simpl. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply BuiltinEffect_unchOn; eassumption.
(*  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply ec_builtinEffectPolymorphic; eassumption.*)
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; try eassumption.
         eapply EmptyEffect_allocvariables; eassumption.
  (*no external call*)
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         apply Mem.unchanged_on_refl.
  (*effstep_sub_val
    destruct IHcsharpmin_effstep.
    split; trivial.
    eapply unchanged_on_validblock; try eassumption.
    intros; simpl. remember (E b ofs) as d.
    destruct d; trivial. apply eq_sym in Heqd.
    rewrite (H _ _ H3 Heqd) in H4. discriminate.*)
Qed.

Lemma csharpminstep_effax2: forall  g c m c' m',
      corestep (csharpmin_coop_sem hf) g c m c' m' ->
      exists M, csharpmin_effstep g M c m c' m'.
Proof.
intros. inv H.
    eexists. eapply csharpmin_effstep_skip_seq.
    eexists. eapply csharpmin_effstep_skip_block.
    eexists. eapply csharpmin_effstep_skip_call; try eassumption.
    eexists. eapply csharpmin_effstep_set; eassumption.
    eexists. eapply csharpmin_effstep_store; eassumption.
    eexists. eapply csharpmin_effstep_call; try eassumption. reflexivity.
    eexists. eapply csharpmin_effstep_builtin; eassumption.
    eexists. eapply csharpmin_effstep_seq.
    eexists. eapply csharpmin_effstep_ifthenelse; eassumption.
    eexists. eapply csharpmin_effstep_loop.
    eexists. eapply csharpmin_effstep_block.
    eexists. eapply csharpmin_effstep_exit_seq.
    eexists. eapply csharpmin_effstep_exit_block_0.
    eexists. eapply csharpmin_effstep_exit_block_S.
    eexists. eapply csharpmin_effstep_switch; eassumption.
    eexists. eapply csharpmin_effstep_return_0; try eassumption.
    eexists. eapply csharpmin_effstep_return_1; try eassumption.
    eexists. eapply csharpmin_effstep_label.
    eexists. eapply csharpmin_effstep_goto; eassumption.
    eexists. eapply csharpmin_effstep_internal_function; try eassumption.
    eexists. eapply csharpmin_effstep_return.
Qed.

Lemma csharpmin_effstep_valid: forall (M : block -> Z -> bool) g c m c' m',
      csharpmin_effstep g M c m c' m' ->
       forall b z, M b z = true -> Mem.valid_block m b.
Proof.
intros.
  induction H; try (solve [inv H0]).

  eapply FreelistEffect_validblock; eassumption.

  apply StoreEffectD in H0. destruct H0 as [ofs [VADDR ARITH]]; subst.
  inv H2. apply Mem.store_valid_access_3 in H3.
  eapply Mem.valid_access_valid_block.
  eapply Mem.valid_access_implies; try eassumption. constructor.

  eapply BuiltinEffect_valid_block; eassumption.

  eapply FreelistEffect_validblock; eassumption.

  eapply FreelistEffect_validblock; eassumption.
Qed.

Program Definition csharpmin_eff_sem :
  @EffectSem Csharpminor.genv CSharpMin_core.
Proof.
eapply Build_EffectSem with (sem := csharpmin_coop_sem hf)
       (effstep:=csharpmin_effstep).
apply csharpminstep_effax1.
apply csharpminstep_effax2.
apply csharpmin_effstep_valid.
Defined.

End CSHARPMINOR_EFF.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

Require Import ComhCoq.Extras.LibTactics.

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.GenTacs.
Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.NetworkLanguage.
Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.ModeStateLanguage.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.ProtAuxDefs.
Require Import ComhCoq.ProtAuxResults.
Require Import ComhCoq.EntAuxDefs.
Require Import ComhCoq.EntAuxResults.
Require Import ComhCoq.NetAuxBasics.
Require Import ComhCoq.NetAuxDefs.
Require Import ComhCoq.NARMisc.

Lemma ovWait_nextSinceState_net m t x y i n :
  ovWaitStateNet m t x y i n -> nextSinceStateNet i n. Admitted (*9*).
(*Proof: Is there some auto tactic for this? #lift-compound-net-tac*)

(*If we are in the ovWaitState then we are either pending or nextSince.*)
Theorem ovWait_nextSince_pending (n : Network) (m : Mode) (t x y : Time) (i : nat)
  (p : reachableNet n) :
  ovWaitStateNet m t x y i n -> pending i n p \/ exists t, nextSince m t i n p.
  (*Proof: Induction on p, the proof of reachability.*)
  introz U. induction p.
  (*The base case fails by contradiction.*)
  initNet_contra U.
  (*In the discrete inductive case, we backtrack for cases of the previous state.*)
  Admitted. (*C- This proof actually goes through based on
  ovReady_nextSince_pending, but the two are mutually inductive so we
  possibly need to combine the two into one result- or figure out a way
  to do mutual induction in Coq. The most straightforward solution to this
  is to prove a mutual result with a conjunction, and then the individual
  results follow easily from this.*)

(*SHARED TACTICS WITH OVWAITSTATE ANALOGUE?
If we are in the ovReadyState then we are either pending or nextSince.*)
Theorem ovReady_nextSince_pending (n : Network) (m : Mode) (t : Time) (i : nat)
  (l : Position) (p : reachableNet n) :
  ovReadyStateNet m t l i n -> pending i n p \/ exists t, nextSince m t i n p.
  introz U.
  (**Proof: Induction on reachable.*)
  induction p.
  (*
  (*Discard base case as initiality contradicts the state predicate*)
  initNet_contra U.
  (*Discrete inductive case- lets backtrack from ovReady*)
  lets OPN : ovReady_prev_net U s. ex_flat. or_flat.
  (*Where the previous case is ovReadySate follows by induction,
  case analysis of the disjunction, and application of the
  appropriate constructor.*)
  lets IH : IHp OR. or_flat.
  (*A previous cas of pending gives a next case of pending.*)
  left. eapply pendingReady; eassumption.
  (*A previous cas of nextSince gives nextSince.*)
  ex_flat. right. eexists. constructor. eassumption.
  eapply ovReady_nextSince_state; eassumption.
  (*So we're left with the discrete case where the previous state is
  ovWaitState m t x y. Then we use (ovWait_nextSince_pending) to show that
  the previous state was either pending or nextSince*)
  ex_flat. lets ONP : ovWait_nextSince_pending H0.
  (*case analyse, and apply the right constructor to get the same for this
  state.*)
  (*Delay inductive case fails by progress [salvaged?].*)
  Admitted. (*C- Need to combine with ovWait_nextSince_pending by some sort
  of mutual induction. See ovWait_nextSince_pending for details.*)*)
  Admitted. (*R*)

Lemma pending_urgent i n n' p d :
  pending i n p -> n -ND- d -ND> n' -> False. Admitted. (*5*)
(**Proof: Induction on pending. BaseType case: ovWait is ready to input a position,
and so is urgent. This readiness is not perverted by any other discreet action,
so the ovWait-ovWait inductive case follows. Both inductive cases with ovReady
as the current state follows immediately from the fact that ovWaitState is
itself urgent*)

(*If we are in the ovWait state with the parameter x = 0,
then the nextSince relation holds.*)
Theorem ovWait_zero_nextSince (n : Network) (m : Mode) (t y : Time) (i : nat)
  (p : reachableNet n) : ovWaitStateNet m t zeroTime y i n ->
  exists t, nextSince m t i n p. Admitted. (*2*)
(**Proof: Induction on reachable. BaseType case fails. For the inductive case(s),
case analyse- is the last state ovWait? If yes, then the result follows easily
by induction. If not, then use (...ovWait_prev...) to get the possible shapes of
the previous state. Well, it can't be initState m, because this would give us
x = tw(m0, m) + period m, which is greater than 0. But x = 0. So our previous
state must have been ovReady m (t + period m) l. Then by (ovReady_nextSince_pending),
the previous state was either pending or nextSince. In either case, there is a
constructor of nextSince that allows us to prove nextSince holds for the current state.*)

(*If we are in the switchBc state, then the nextSince relation holds.*)
Theorem switchBc_nextSince (n : Network) (m : Mode) (i : nat)
  (p : reachableNet n) : switchBcStateNet m i n -> exists t, nextSince m t i n p.
  Admitted. (*2*)
(**Proof: By induction on reachable. Eliminate the easy cases, leaving us with the
discrete inductive case with the previous state not switchBcState. Then we use
(...switchBc_prev...) to give us ovWait m t 0 y as the predecessor state- we know
the parameter x is 0 because the transition would have to have been enabled.
Then by (ovWait_nextSince_pending & elimination of the pending case somehow) we have that the previous state was nextSince and so by
application of the nextSince discrete constructor so is this one.*)

(*If we are in the switchCurr state, then the nextSince relation holds.	*)
Theorem switchCurr_nextSince (n : Network) (m : Mode) (i : nat)
  (p : reachableNet n) : switchCurrStateNet i n ->
  exists t, nextSince m t i n p. Admitted. (*2*)
(**Proof: By induction on reachable and (...switchCurr_prev...) to give us switchBc m
as the predecessor state. Then by (swtichBc_nextSince) and application of the nextSince
discrete constructor our results follows.*)

(* Let's say in a reachable network, an entity is in non-fail-safe mode m.
Then that entity has been currSince m t.*)
Theorem nonFS_currSince (m : Mode) (i : nat) (n : Network)
  (p : reachableNet n) : currModeNet m i n -> ~failSafe m ->
  exists t, currSince m t i n p.
  intros.
  (**Proof: Induction on the proof of reachability of n.*)
  induction p.
  (*In the base case, we have that n is initial. Hence all its constituent entities
  are in fail safe modes. So the assumption that entity i is in mode m which is not
  fail safe is contradictory, case closed.*)
  apply currMode_ent_ex in H. decompose [ex] H. clear H. rename x into e.
  invertClear H1. rewrite <- H2 in H0. apply False_ind. apply H0.
  eapply initial_failSafe. apply i0. apply H.
  (*Which leaves us the inductive cases. We start with the discrete inductive case.
  Here, we do a case analysis on whether the previous state was currMode m.*)
  addHyp (currModeNet_dec m i n). invertClear H1.
  (*If it was, then by the inductive hypothesis, we get currSince m t for
  the previous state*)
  apply IHp in H2. invertClear H2. rename x into t.
  (*Which immediately follows on to this state by the inductive definition of currSince.*)
  exists t. eapply currSinceDisc. apply H1. assumption.
  (*Otherwise, the previous state was not currMode m. And so it must have been currMode m'
  for some m' <> m (Basics::currMode_pres_bkwd).*)
  addHyp (currMode_pres_bkwd n n' a m i s H). invertClear H1. rename x into m'.
  assert (m' <> m). unfold not. intros. rewrite H1 in H3. apply H2. assumption.
  (*And so we can show that since the current mode has changed between states,
  the entity i must have performed a tau transition.*)
  addHyp H. rewrite (currMode_ent_ex m i n') in H4.
  addHyp H3. rewrite (currMode_ent_ex m' i n) in H5.
  invertClear H4. invertClear H5. invertClear H4. invertClear H6.
  rename x0 into e. rename x into e'.
  addHyp (curr_switch_ent_tau n n' a e e' i m' m s H5 H4 H7 H8 H1).
  (*We can also show that the software component contributed an output on mCurr and the
  mode-state contributed an input (EA::curr_switch_proc).*)
  rename p into X. destruct e as [p l h k]. destruct e' as [p' l' h' k'].
  addHyp (currMode_ent_mState p l h k m' H7). addHyp (currMode_ent_mState p' l' h' k' m H8).
  assert (currModeMState k <> currModeMState k'). rewrite H9. rewrite H10. assumption.
  addHyp (curr_switch_proc p p' l l' h h' k k' H6 H11). invertClear H12.
  (*Now, we since n is reachable, so is p, and so p is a triple of processes*)
  addHyp (reachable_net_prot n i p l h k X H5). apply reachableProt_triple in H12.
  invertClear H12. rewrite <- H18 in H13.
  (*And so one of the sub components P1, P2 or P3 must have performed this output.*)
  link_partripdiscex_tac Y p1' p2' p3'. rewrite Y in H13.
  link_partripout_tac U;[
  (*We eliminate the possibility P1 by (bc_mCurr_out_not)*)
  false; eapply bc_mCurr_out_not; [apply U | assumption] | |
  (*and we eliminate P3 with (listen_mCurr_not).*)
  false; eapply listen_mCurr_out_not; [apply U | assumption]].
  (*Then by (...ovlp_mCurr_out...) we show that P2 was in the state switchCurrState,
  while the next state had P2' in switchListenState*)
  lets OO : ovlp_mCurr_out U H16.
  (*We can eliminate the tfs case because failSafe m contradicts our hypothesis.*)
  elim_intro OO SW TF. Focus 2.
  assert (tfsBcStateEnt ([|p', l', h', k'|])). constructor. rewrite Y.
  constructor. apply TF. apply tfsBc_failSafe in H12.
  simpl in H12. rewrite H10 in H12. false.
  (*This allows us to conclude that the previous state was nextSince m t i n for some t
  (switchCurr_nextSince)*)
  assert (switchCurrStateEnt ([|p, l, h, k|])).
  constructor. rewrite <- H18. constructor. apply SW.
  assert (switchCurrStateNet i n). econstructor. apply H12. assumption.
  addHyp (switchCurr_nextSince n m i X H19). invertClear H20.
  rename x into t.
  (*Now finally, by the base case of currSince, we can show that
  currSince m t i n holds.*)
  exists t. constructor. assumption. assumption. econstructor.
  constructor. constructor. apply SW. rewrite Y in H4. apply H4.
  (*For the delay inductive case, we first notice that delay preserves the current mode*)
  addHyp (currMode_del_pres_bkwd n n' d m i s H).
  (*Then we apply the I.H. to get that the previous mode was currSince.*)
  apply IHp in H1. invertClear H1. rename x into t.
  (*And now as our existential we take t + d*. And by the delay constructor of
  currSince, we're done.*)
  exists (t +dt+ d). constructor. assumption. Qed.