(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Sim_Pres
  imports Weak_Early_Sim
begin

lemma tauPres:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PRelQ: "(P, Q) \<in> Rel"

  shows "\<tau>.(P) \<leadsto><Rel> \<tau>.(Q)"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "\<tau>.(Q) \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  hence False by(induct rule: tauCases', auto)
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "\<tau>.(Q) \<longmapsto>(\<alpha> \<prec> Q')" by fact
  thus ?case
  proof(induct rule: tauCases', auto simp only: pi.inject residual.inject)
    have "\<tau>.(P) \<Longrightarrow>\<^sup>^ \<tau> \<prec> P" by(rule Tau)
    with PRelQ show "\<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

lemma inputPres:
  fixes P    :: pi
  and   x    :: name
  and   Q    :: pi
  and   a    :: name
  and   Rel  :: "(pi \<times> pi) set"

  assumes PRelQ: "\<forall>y. (P[x::=y], Q[x::=y]) \<in> Rel"
  and     Eqvt: "eqvt Rel"

  shows "a<x>.P \<leadsto><Rel> a<x>.Q"
using Eqvt
proof(induct rule: simCasesCont[where C="(x, a, P, Q)"])
  case(Bound b y Q')
  from `y \<sharp> (x, a, P, Q)` have "y \<noteq> x" "y \<noteq> a" "y \<sharp> P" "y \<sharp> Q" by simp+
  from `a<x>.Q \<longmapsto>b<\<nu>y> \<prec> Q'` `y \<noteq> a` `y \<noteq> x` `y \<sharp> Q` show ?case
    by(erule_tac inputCases') auto
next
  case(Free \<alpha> Q')
  from `a<x>.Q \<longmapsto> \<alpha> \<prec> Q'`
  show ?case
  proof(induct rule: inputCases)
    case(cInput u)
    have "a<x>.P \<Longrightarrow>\<^sup>^(a<u>) \<prec> P[x::=u]"
      by(rule Input)
    moreover from PRelQ have "(P[x::=u], Q[x::=u]) \<in> Rel" by auto
    ultimately show ?case by blast
  qed
qed

lemma outputPres:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: name
  and   b    :: name
  and   Rel  :: "(pi \<times> pi) set"

  assumes PRelQ: "(P, Q) \<in> Rel"

  shows "a{b}.P \<leadsto><Rel> a{b}.Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "a{b}.Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  hence False by(induct rule: outputCases', auto)
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "a{b}.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus "\<exists>P'. a{b}.P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: outputCases', auto simp add: pi.inject residual.inject)
    have "a{b}.P \<Longrightarrow>\<^sup>^ a[b] \<prec> P" by(rule Output)
    with PRelQ show "\<exists>P'. a{b}.P \<Longrightarrow>\<^sup>^ a[b] \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     RelStay: "\<And>R S c. (R, S) \<in> Rel \<Longrightarrow> ([c\<frown>c]R, S) \<in> Rel"

  shows "[a\<frown>b]P \<leadsto><Rel'> [a\<frown>b]Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "x \<sharp> [a\<frown>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>c<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>c<\<nu>x> \<prec> P'" by(rule Weak_Early_Step_Semantics.Match)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "[a\<frown>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(blast dest: simE)
    thus ?case
    proof(induct rule: transitionCases)
      case Step
      have "P \<Longrightarrow>\<alpha> \<prec> P'" by fact
      hence "[a\<frown>a]P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Match)
      with RelRel' `(P', Q') \<in> Rel` show ?case by(force simp add: weakFreeTransition_def)
    next
      case Stay
      have "[a\<frown>a]P \<Longrightarrow>\<^sup>^\<tau> \<prec> [a\<frown>a]P" by(simp add: weakFreeTransition_def)
      moreover from `(P, Q') \<in> Rel` have "([a\<frown>a]P, Q') \<in> Rel" by(blast intro: RelStay)
      ultimately show ?case using RelRel' by blast
    qed
  qed
qed

lemma mismatchPres:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: name
  and   b    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     RelStay: "\<And>R S c d. \<lbrakk>(R, S) \<in> Rel; c \<noteq> d\<rbrakk> \<Longrightarrow> ([c\<noteq>d]R, S) \<in> Rel"

  shows "[a\<noteq>b]P \<leadsto><Rel'> [a\<noteq>b]Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "x \<sharp> [a\<noteq>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<noteq>b]Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: mismatchCases)
    case Mismatch
    have aineqb: "a \<noteq> b" by fact
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>c<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans aineqb have "[a\<noteq>b]P \<Longrightarrow>c<\<nu>x> \<prec> P'" by(rule Weak_Early_Step_Semantics.Mismatch)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "[a\<noteq>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: mismatchCases)
    case Mismatch
    have aineqb: "a \<noteq> b" by fact
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(blast dest: simE)
    thus ?case
    proof(induct rule: transitionCases)
      case Step
      have "P \<Longrightarrow>\<alpha> \<prec> P'" by fact
      hence "[a\<noteq>b]P \<Longrightarrow>\<alpha> \<prec> P'" using aineqb by(rule Weak_Early_Step_Semantics.Mismatch)
      with RelRel' `(P', Q') \<in> Rel` show ?case by(force simp add: weakFreeTransition_def)
    next
      case Stay
      have "[a\<noteq>b]P \<Longrightarrow>\<^sup>^\<tau> \<prec> [a\<noteq>b]P" by(simp add: weakFreeTransition_def)
      moreover from `(P, Q') \<in> Rel` aineqb have "([a\<noteq>b]P, Q') \<in> Rel" by(blast intro: RelStay)
      ultimately show ?case using RelRel' by blast
    qed
  qed
qed

lemma parCompose:
  fixes P     :: pi
  and   Q     :: pi
  and   R     :: pi
  and   S     :: pi
  and   Rel   :: "(pi \<times> pi) set"
  and   Rel'  :: "(pi \<times> pi) set"
  and   Rel'' :: "(pi \<times> pi) set"

  assumes PSimQ:    "P \<leadsto><Rel> Q"
  and     RSimT:    "R \<leadsto><Rel'> S"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     RRel'T:   "(R, S) \<in> Rel'"
  and     Par:      "\<And>P' Q' R' S'. \<lbrakk>(P', Q') \<in> Rel; (R', S') \<in> Rel'\<rbrakk> \<Longrightarrow> (P' \<parallel> R', Q' \<parallel> S') \<in> Rel''"
  and     Res:      "\<And>T U x. (T, U) \<in> Rel'' \<Longrightarrow> (<\<nu>x>T, <\<nu>x>U) \<in> Rel''"

  shows "P \<parallel> R \<leadsto><Rel''> Q \<parallel> S"
proof -
  show ?thesis
  proof(induct rule: simCases)
    case(Bound Q' a x)
    have "x \<sharp> P \<parallel> R" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
    have "Q \<parallel> S \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: parCasesB)
      case(cPar1 Q')
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" and xFreshT: "x \<sharp> S" by fact+
      from xFreshP PSimQ QTrans obtain P' where PTrans:"P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Weak_Early_Step_Semantics.Par1B)
      moreover from P'RelQ' RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cPar2 S')
      have STrans: "S \<longmapsto> a<\<nu>x> \<prec> S'" and xFreshQ: "x \<sharp> Q" by fact+
      from xFreshR RSimT STrans obtain R' where RTrans:"R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                            and R'Rel'T': "(R', S') \<in>  Rel'"
        by(blast dest: simE)
      from RTrans xFreshP xFreshR have ParTrans: "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> R')"
        by(blast intro: Weak_Early_Step_Semantics.Par2B)
      moreover from PRelQ R'Rel'T' have "(P \<parallel> R', Q \<parallel>  S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    qed
  next
    case(Free QT' \<alpha>)
    have "Q \<parallel> S \<longmapsto> \<alpha> \<prec> QT'" by fact
    thus ?case
    proof(induct rule: parCasesF[of _ _ _ _ _ "(P, R)"])
      case(cPar1 Q')
      have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Semantics.Par1F)
      moreover from PRel RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(blast intro: Par)
      ultimately show ?case by blast
    next
      case(cPar2 S')
      have "S \<longmapsto> \<alpha> \<prec> S'" by fact
      with RSimT obtain R' where RTrans: "R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> R'" and RRel: "(R', S') \<in> Rel'"
        by(blast dest: simE)
      from RTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Semantics.Par2F)
      moreover from PRelQ RRel have "(P \<parallel> R', Q \<parallel> S') \<in> Rel''" by(blast intro: Par)
      ultimately show ?case by blast
    next
      case(cComm1 Q' S' a b)
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" and STrans: "S \<longmapsto> a[b] \<prec> S'" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a[b] \<prec> R'"
                                    and RRel: "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm1)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)

      moreover from P'RelQ' RRel have "(P' \<parallel> R', Q' \<parallel> S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cComm2 Q' S' a b)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" and STrans: "S \<longmapsto>a<b> \<prec> S'" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a[b] \<prec> P'"
                                    and PRel: "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a<b> \<prec> R'"
                                   and R'Rel'T': "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm2)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from PRel R'Rel'T' have "(P' \<parallel> R', Q' \<parallel> S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cClose1 Q' S' a x)
      have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and STrans: "S \<longmapsto>a<\<nu>x> \<prec> S'" by fact+
      have "x \<sharp> (P, R)" by fact
      hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by(simp add: fresh_prod)+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a<x> \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                            and R'Rel'T': "(R', S') \<in> Rel'"
        by(blast dest: simE)

      from PTrans RTrans xFreshP have Trans: "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(rule Weak_Early_Step_Semantics.Close1)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    next
      case(cClose2 Q' S' a x)
      have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and STrans: "S \<longmapsto>a<x> \<prec> S'" by fact+
      have "x \<sharp> (P, R)" by fact
      hence xFreshR: "x \<sharp> R" and xFreshP: "x \<sharp> P" by(simp add: fresh_prod)+

      from PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'"
                                    and R'Rel'T': "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)
      from PTrans RTrans xFreshR have Trans: "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(rule Weak_Early_Step_Semantics.Close2)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    qed
  qed
qed

lemma parPres:
  fixes P   :: pi
  and   Q   :: pi
  and   R   :: pi
  and   a   :: name
  and   Rel :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PSimQ:    "P \<leadsto><Rel> Q"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     Par:      "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<parallel> U, T \<parallel> U) \<in> Rel'"
  and     Res:      "\<And>S T x. (S, T) \<in> Rel' \<Longrightarrow> (<\<nu>x>S, <\<nu>x>T) \<in> Rel'"

  shows "P \<parallel> R \<leadsto><Rel'> Q \<parallel> R"
proof -
  note PSimQ
  moreover have RSimR: "R \<leadsto><Id> R" by(auto intro: reflexive)
  moreover note PRelQ moreover have "(R, R) \<in> Id" by auto
  moreover from Par have "\<And>P Q R T. \<lbrakk>(P, Q) \<in> Rel; (R, T) \<in> Id\<rbrakk> \<Longrightarrow> (P \<parallel> R, Q \<parallel> T) \<in> Rel'"
    by auto
  ultimately show ?thesis using Res by(rule parCompose)
qed

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     ResRel: "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>y>R, <\<nu>y>S) \<in> Rel'"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel: "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "<\<nu>x>P \<leadsto><Rel'> <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[where C="(P, x)"])
    case(Bound a y Q')
    have Trans: "<\<nu>x>Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
    have "y \<sharp> (P, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" by(simp add: fresh_prod)+
    from Trans yineqx show ?case
    proof(induct rule: resCasesB)
      case(Open Q')
      have QTrans: "Q \<longmapsto>a[x] \<prec> Q'" and aineqx: "a \<noteq> x" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^a[x] \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      from PTrans aineqx have "<\<nu>x>P \<Longrightarrow>a<\<nu>x> \<prec> P'"
        by(force intro: Weak_Early_Step_Semantics.Open simp add: weakFreeTransition_def)
      with `y \<sharp> P` `y \<noteq> x` have "<\<nu>x>P \<Longrightarrow>a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
        by(force intro: weakTransitionAlpha simp add: abs_fresh name_swap)
      moreover from EqvtRel P'RelQ' RelRel' have "([(y, x)] \<bullet> P', [(y, x)] \<bullet> Q') \<in> Rel'"
        by(blast intro: eqvtRelI)
      ultimately show ?case by blast
    next
      case(Res Q')
      have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" and xineqa: "x \<noteq> a" by fact+

      from PSimQ yFreshP QTrans obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>y> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans xineqa yineqx yFreshP have ResTrans: "<\<nu>x>P \<Longrightarrow>a<\<nu>y> \<prec> (<\<nu>x>P')"
        by(blast intro: Weak_Early_Step_Semantics.ResB)
      moreover from P'RelQ' have "((<\<nu>x>P'), (<\<nu>x>Q')) \<in> Rel'"
        by(rule ResRel)
      ultimately show ?case by blast
    qed
  next
    case(Free \<alpha> Q')
    have QTrans: "<\<nu>x>Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    have "\<exists>c::name. c \<sharp> (P, Q, Q', \<alpha>)" by(blast intro: name_exists_fresh)
    then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshAlpha: "c \<sharp> \<alpha>" and cFreshQ': "c \<sharp> Q'" and cFreshP: "c \<sharp> P"
      by(force simp add: fresh_prod)
    from cFreshP have "<\<nu>x>P = <\<nu>c>([(x, c)] \<bullet> P)" by(simp add: alphaRes)
    moreover have "\<exists>P'.<\<nu>c>([(x, c)] \<bullet> P) \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
    proof -
      from QTrans cFreshQ have "<\<nu>c>([(x, c)] \<bullet> Q) \<longmapsto>\<alpha> \<prec> Q'" by(simp add: alphaRes)
      moreover have "c \<sharp> \<alpha>" by(rule cFreshAlpha)
      moreover from PSimQ EqvtRel have "([(x, c)] \<bullet> P) \<leadsto><Rel> ([(x, c)] \<bullet> Q)"
        by(blast intro: eqvtI)
      ultimately show ?thesis
        apply(induct rule: resCasesF, auto simp add: residual.inject pi.inject name_abs_eq)
        by(blast intro: ResF ResRel dest: simE)
    qed

    ultimately show ?case by force
  qed
qed

lemma resChainI:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   lst :: "name list"

  assumes eqvtRel: "eqvt Rel"
  and     Res:     "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>y>R, <\<nu>y>S) \<in> Rel"
  and     PRelQ:   "P \<leadsto><Rel> Q"

  shows "(resChain lst) P \<leadsto><Rel> (resChain lst) Q"
proof -
  show ?thesis
  proof(induct lst) (* Base case *)
    from PRelQ show "resChain [] P \<leadsto><Rel> resChain [] Q" by simp
  next (* Inductive step *)
    fix a lst
    assume IH: "(resChain lst P) \<leadsto><Rel> (resChain lst Q)"
    moreover from Res have "\<And>P Q a. (P, Q) \<in> Rel \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> Rel"
      by simp
    moreover have "Rel \<subseteq> Rel" by simp
    ultimately have "<\<nu>a>(resChain lst P) \<leadsto><Rel> <\<nu>a>(resChain lst Q)" using eqvtRel
      by(rule_tac resPres)
    thus "resChain (a # lst) P \<leadsto><Rel> resChain (a # lst) Q"
      by simp
  qed
qed

  and     ParComp:     "\<And>R S T U. \<lbrakk>(R, S) \<in> Rel; (T, U) \<in> Rel'\<rbrakk> \<Longrightarrow> (R \<parallel> T, S \<parallel> U) \<in> Rel'"
  and     Res:         "\<And>R S x. (R, S) \<in> Rel' \<Longrightarrow> (<\<nu>x>R, <\<nu>x>S) \<in> Rel'"

  and     RelStay:        "\<And>R S. (R \<parallel> !R, S) \<in> Rel' \<Longrightarrow> (!R, S) \<in> Rel'"
  and     BangRelRel': "(bangRel Rel) \<subseteq> Rel'"
  and     eqvtRel':    "eqvt Rel'"

  shows "!P \<leadsto><Rel'> !Q"
proof -
  let ?Sim = "\<lambda>P Rs. (\<forall>a x Q'. Rs = a<\<nu>x> \<prec> Q' \<longrightarrow> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel')) \<and>
                     (\<forall>\<alpha> Q'. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'))"
  {
    fix Rs P
    assume "!Q \<longmapsto> Rs" and "(P, !Q) \<in> bangRel Rel"
    hence "?Sim P Rs" using PRelQ
    proof(nominal_induct avoiding: P rule: bangInduct)
      case(Par1B a x Q')
      have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and xFreshQ: "x \<sharp> Q" by fact+
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelT: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        from PRelQ have PSimQ: "P \<leadsto><Rel> Q" by(rule Sim)
        from `x \<sharp> P` `x \<sharp> Q` show ?case
        proof(auto simp add: residual.inject alpha' name_fresh_fresh)
          from PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                                and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)
          from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>a<\<nu>x>\<prec> (P' \<parallel> R)"
            by(rule Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' RBangRelT BangRelRel' have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> Rel'"
            by(blast intro: Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> Rel'" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q'" and "y \<sharp> P" and "y \<sharp> R"
          from QTrans `y \<sharp> Q'` have "Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q')" by(simp add: alphaBoundOutput)
          with PSimQ `y \<sharp> P` obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>y> \<prec> P'"
                                         and P'RelQ': "(P', [(x, y)] \<bullet> Q') \<in> Rel"
            by(blast dest: simE)
          from PTrans `y \<sharp> R` have "P \<parallel> R \<Longrightarrow>a<\<nu>y>\<prec> (P' \<parallel> R)" by(rule Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' RBangRelT BangRelRel' have "(P' \<parallel> R, ([(y, x)] \<bullet> Q') \<parallel> !Q) \<in> Rel'"
            by(fastforce intro: Rel.BRPar simp add: name_swap)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> P' \<and> (P', ([(y, x)] \<bullet> Q') \<parallel> !Q) \<in> Rel'" by blast
        qed
      qed
    next
      case(Par1F \<alpha> Q' P)
      have QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Semantics.Par1F)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel"
            by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> Rel'" using BangRelRel' by blast
        qed
      qed
    next
      case(Par2B a x Q' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<\<nu>x> \<prec> Q')" by simp
      have xFreshQ: "x \<sharp> Q" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case using `x \<sharp> Q`
        proof(auto simp add: residual.inject alpha' name_fresh_fresh)
          from IH RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q')" by blast
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'" and R'BangRelQ': "(R', Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> R')"
            by(auto intro: Weak_Early_Step_Semantics.Par2B)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> Rel'" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q'" and "y \<sharp> R" and "y \<sharp> P"
          from IH RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q')" by blast
          with `y \<sharp> Q'` have  "?Sim R (a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q'))" by(simp add: alphaBoundOutput)
          with `y \<sharp> R`obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>y> \<prec> R'" and R'BangRelQ': "(R', [(x, y)] \<bullet> Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans `y \<sharp> P` have "P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> (P \<parallel> R')"
            by(auto intro: Weak_Early_Step_Semantics.Par2B)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> ([(y, x)] \<bullet> Q')) \<in> Rel'"
            by(fastforce intro: ParComp simp add: name_swap)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> P' \<and> (P', Q \<parallel> ([(y, x)] \<bullet> Q')) \<in> Rel'" by blast
        qed
      qed
    next
      case(Par2F \<alpha> Q' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (\<alpha> \<prec> Q')" by simp
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from RBangRelQ have "?Sim R (\<alpha> \<prec> Q')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Semantics.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'" by(rule ParComp)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> Rel'" by blast
        qed
      qed
    next
      case(Comm1 a Q' b Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a[b] \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a[b] \<prec> Q'')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a[b] \<prec> R'"
                           and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce dest: simE simp add: weakFreeTransition_def)
          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm1)
          hence "P \<parallel> R \<Longrightarrow>\<^sub>\<tau> P' \<parallel> R'"
            by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', Q' \<parallel> Q'') \<in> Rel'"
            by auto
        qed
      qed
    next
      case(Comm2 a b Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<b> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a<b> \<prec> Q'')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a<b> \<prec> R'" and R'BangRelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm2)
          hence "P \<parallel> R \<Longrightarrow>\<^sub>\<tau> P' \<parallel> R'"
            by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
          moreover from P'RelQ' R'BangRelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', Q' \<parallel> Q'') \<in> Rel'" by auto
        qed
      qed
    next
      case(Close1 a x Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<\<nu>x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshR: "x \<sharp> R" and xFreshP: "x \<sharp> P" by simp+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q'') " by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                   and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(blast dest: simE)

          from PTrans RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Close1)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'" by auto
        qed
      qed
    next
      case(Close2 a x Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "?Sim R (a<x> \<prec> Q'')" by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'"
                                       and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce simp add: weakFreeTransition_def)
          from PTrans RTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Close2)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'" by auto
        qed
      qed
    next
      case(Bang Rs)
      hence IH: "\<And>P. (P, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P Rs" by simp
      have "(P, !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        have PRelQ: "(P, Q) \<in> Rel" by fact
        hence "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
        with PRelQ have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
        hence IH: "?Sim (P \<parallel> !P) Rs" by(rule IH)
        show ?case
        proof(intro conjI allI impI)
          fix Q' a x
          assume "Rs = a<\<nu>x> \<prec> Q'" and "x \<sharp> !P"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>a<\<nu>x> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'" using IH
            by(auto simp add: residual.inject)
          from PTrans have "!P \<Longrightarrow>a<\<nu>x> \<prec> P'"
            by(force intro: Weak_Early_Step_Semantics.Bang simp add: weakFreeTransition_def)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel'" by blast
        next
          fix Q' \<alpha>
          assume "Rs = \<alpha> \<prec> Q'"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'" using IH
            by auto
          from PTrans show "\<exists>P'. !P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" using P'RelQ'
          proof(induct rule: transitionCases)
            case Step
            have "P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P'" by fact
            hence "!P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Bang)
            with P'RelQ' show ?case by(force simp add: weakFreeTransition_def)
          next
            case Stay
            have "!P \<Longrightarrow>\<^sup>^\<tau> \<prec> !P" by(simp add: weakFreeTransition_def)
            moreover assume "(P \<parallel> !P, Q') \<in> Rel'"
            hence "(!P, Q') \<in> Rel'" by(blast intro: RelStay)
            ultimately show ?case by blast
          qed
        qed
      qed
    qed
  }
  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
  ultimately show ?thesis by(auto simp add: weakSimulation_def)
qed

lemma bangRelSim:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel'l :: "(pi \<times> pi) set"

  assumes PBangRelQ: "(P, Q) \<in> bangRel Rel"
  and     Sim:       "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto><Rel> S"

  and     ParComp:     "\<And>R S T U. \<lbrakk>(R, S) \<in> Rel; (T, U) \<in> Rel'\<rbrakk> \<Longrightarrow> (R \<parallel> T, S \<parallel> U) \<in> Rel'"
  and     Res:         "\<And>R S x. (R, S) \<in> Rel' \<Longrightarrow> (<\<nu>x>R, <\<nu>x>S) \<in> Rel'"

  and     RelStay:        "\<And>R S. (R \<parallel> !R, S) \<in> Rel' \<Longrightarrow> (!R, S) \<in> Rel'"
  and     BangRelRel': "(bangRel Rel) \<subseteq> Rel'"
  and     eqvtRel':    "eqvt Rel'"
  and     Eqvt: "eqvt Rel"

  shows "P \<leadsto><Rel'> Q"
proof -
  from PBangRelQ show ?thesis
  proof(induct rule: bangRel.induct)
    case(BRBang P Q)
    have PRelQ: "(P, Q) \<in> Rel" by fact
    thus ?case using ParComp Res BangRelRel' eqvtRel' Eqvt RelStay Sim
      by(rule_tac bangPres)
  next
    case(BRPar P Q R T)
    have "(P, Q) \<in> Rel" by fact
    moreover hence "P \<leadsto><Rel> Q" by(rule Sim)
    moreover have "R \<leadsto><Rel'> T" by fact
    moreover have "(R, T) \<in> bangRel Rel" by fact
    ultimately show ?case using ParComp eqvtRel' Res Eqvt BangRelRel'
      by(blast intro: parCompose)
  next
    case(BRRes P Q x)
    have "P \<leadsto><Rel'> Q" by fact
    thus ?case using BangRelRel' eqvtRel' Res by(blast intro: resPres)
  qed
qed

end


section {* Operational Semantics *}

theory RG_Tran
imports RG_Com
begin

subsection {* Semantics of Component Programs *}

subsubsection {* Environment transitions *}

type_synonym 'a conf = "(('a com) option) \<times> 'a"

inductive_set
  etran :: "('a conf \<times> 'a conf) set"
  and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"  ("_ -e\<rightarrow> _" [81,81] 80)
where
  "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
| Env: "(P, s) -e\<rightarrow> (P, t)"

lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (induct c, induct c', erule etran.cases, blast)

subsubsection {* Component transitions *}

inductive_set
  ctran :: "('a conf \<times> 'a conf) set"
  and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"   ("_ -c\<rightarrow> _" [81,81] 80)
  and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"   ("_ -c*\<rightarrow> _" [81,81] 80)
where
  "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran^*"

| Basic:  "(Some(Basic f), s) -c\<rightarrow> (None, f s)"

| Seq1:   "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"

| Seq2:   "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"

| CondT: "s\<in>b  \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"

| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
| WhileT: "s\<in>b  \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"

| Await:  "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"

monos "rtrancl_mono"

subsection {* Semantics of Parallel Programs *}

type_synonym 'a par_conf = "('a par_com) \<times> 'a"

inductive_set
  par_etran :: "('a par_conf \<times> 'a par_conf) set"
  and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
where
  "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
| ParEnv:  "(Ps, s) -pe\<rightarrow> (Ps, t)"

inductive_set
  par_ctran :: "('a par_conf \<times> 'a par_conf) set"
  and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
where
  "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"

lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
  (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
     (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
  by (induct c, induct c', erule par_ctran.cases, blast)

subsection {* Computations *}

subsubsection {* Sequential computations *}

type_synonym 'a confs = "'a conf list"

inductive_set cptn :: "'a confs set"
where
  CptnOne: "[(P,s)] \<in> cptn"
| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"

definition cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set" where
  "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"

subsubsection {* Parallel computations *}

type_synonym 'a par_confs = "'a par_conf list"

inductive_set par_cptn :: "'a par_confs set"
where
  ParCptnOne: "[(P,s)] \<in> par_cptn"
| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"

definition par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set" where
  "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"

subsection{* Modular Definition of Computation *}

definition lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf" where
  "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"

inductive_set cptn_mod :: "('a confs) set"
where
  CptnModOne: "[(P, s)] \<in> cptn_mod"
| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
                 \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
| CptnModSeq2:
  "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
  (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
  zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"

| CptnModWhile1:
  "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
  \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
| CptnModWhile2:
  "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
  zs=(map (lift (While b P)) xs)@ys;
  (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
  \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"

subsection {* Equivalence of Both Definitions.*}

lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
  by (induct xs) auto

lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
 (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
  (\<exists>xs. (Some P, s)#xs \<in> cptn_mod  \<and> (zs=(map (lift Q) xs) \<or>
  ( fst(((Some P, s)#xs)!length xs)=None \<and>
  (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
  \<and> zs=(map (lift (Q)) xs)@ys)))))"
apply(erule cptn_mod.induct)
apply simp_all
    apply clarify
    apply(force intro:CptnModOne)
   apply clarify
   apply(erule_tac x=Pa in allE)
   apply(erule_tac x=Q in allE)
   apply simp
   apply clarify
   apply(erule disjE)
    apply(rule_tac x="(Some Pa,t)#xsa" in exI)
    apply(rule conjI)
     apply clarify
     apply(erule CptnModEnv)
    apply(rule disjI1)
    apply(simp add:lift_def)
   apply clarify
   apply(rule_tac x="(Some Pa,t)#xsa" in exI)
   apply(rule conjI)
    apply(erule CptnModEnv)
   apply(rule disjI2)
   apply(rule conjI)
    apply(case_tac xsa,simp,simp)
   apply(rule_tac x="ys" in exI)
   apply(rule conjI)
    apply simp
   apply(simp add:lift_def)
  apply clarify
  apply(erule ctran.cases,simp_all)
 apply clarify
 apply(rule_tac x="xs" in exI)
 apply simp
 apply clarify
apply(rule_tac x="xs" in exI)
apply(simp add: last_length)
done

lemma cptn_onlyif_cptn_mod_aux [rule_format]:
  "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
  \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
apply(induct a)
apply simp_all
--{* basic *}
apply clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,rule Basic,simp)
apply clarify
apply(erule ctran.cases,simp_all)
--{* Seq1 *}
apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
  apply(erule CptnModNone)
  apply(rule CptnModOne)
 apply simp
apply simp
apply(simp add:lift_def)
--{* Seq2 *}
apply(erule_tac x=sa in allE)
apply(erule_tac x="Some P2" in allE)
apply(erule allE,erule impE, assumption)
apply(drule div_seq,simp)
apply clarify
apply(erule disjE)
 apply clarify
 apply(erule allE,erule impE, assumption)
 apply(erule_tac CptnModSeq1)
 apply(simp add:lift_def)
apply clarify
apply(erule allE,erule impE, assumption)
apply(erule_tac CptnModSeq2)
  apply (simp add:last_length)
 apply (simp add:last_length)
apply(simp add:lift_def)
--{* Cond *}
apply clarify
apply(erule ctran.cases,simp_all)
apply(force elim: CptnModCondT)
apply(force elim: CptnModCondF)
--{* While *}
apply  clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,erule WhileF,simp)
apply(drule div_seq,force)
apply clarify
apply (erule disjE)
 apply(force elim:CptnModWhile1)
apply clarify
apply(force simp add:last_length elim:CptnModWhile2)
--{* await *}
apply clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,erule Await,simp+)
done

lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
apply(erule cptn.induct)
  apply(rule CptnModOne)
 apply(erule CptnModEnv)
apply(case_tac P)
 apply simp
 apply(erule ctran.cases,simp_all)
apply(force elim:cptn_onlyif_cptn_mod_aux)
done

lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
apply(erule cptn.induct)
  apply(force simp add:lift_def CptnOne)
 apply(force intro:CptnEnv simp add:lift_def)
apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
done

lemma cptn_append_is_cptn [rule_format]:
 "\<forall>b a. b#c1\<in>cptn \<longrightarrow>  a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
apply(induct c1)
 apply simp
apply clarify
apply(erule cptn.cases,simp_all)
 apply(force intro:CptnEnv)
apply(force elim:CptnComp)
done

lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
 \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
  by (cases "(xs ! (length xs - (Suc 0)))") (simp add:lift_def)

lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
  by (induct x) simp_all

lemma last_fst_esp:
 "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
apply(erule last_fst)
apply simp
done

lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
  snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
  by (cases "(xs ! (length xs - (Suc 0)))") (simp_all add:lift_def)

lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
  by (simp add:lift_def)

lemma Cons_lift_append:
  "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
  by (simp add:lift_def)

lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q  (xs! i)"
  by (simp add:lift_def)

lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
  by (cases "xs!i") (simp add:lift_def)

lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
apply(erule cptn_mod.induct)
        apply(rule CptnOne)
       apply(erule CptnEnv)
      apply(erule CptnComp,simp)
     apply(rule CptnComp)
      apply(erule CondT,simp)
    apply(rule CptnComp)
     apply(erule CondF,simp)
--{* Seq1 *}
apply(erule cptn.cases,simp_all)
  apply(rule CptnOne)
 apply clarify
 apply(drule_tac P=P1 in lift_is_cptn)
 apply(simp add:lift_def)
 apply(rule CptnEnv,simp)
apply clarify
apply(simp add:lift_def)
apply(rule conjI)
 apply clarify
 apply(rule CptnComp)
  apply(rule Seq1,simp)
 apply(drule_tac P=P1 in lift_is_cptn)
 apply(simp add:lift_def)
apply clarify
apply(rule CptnComp)
 apply(rule Seq2,simp)
apply(drule_tac P=P1 in lift_is_cptn)
apply(simp add:lift_def)
--{* Seq2 *}
apply(rule cptn_append_is_cptn)
  apply(drule_tac P=P1 in lift_is_cptn)
  apply(simp add:lift_def)
 apply simp
apply(simp split: split_if_asm)
apply(frule_tac P=P1 in last_lift)
 apply(rule last_fst_esp)
 apply (simp add:last_length)
apply(simp add:Cons_lift lift_def split_def last_conv_nth)
--{* While1 *}
apply(rule CptnComp)
 apply(rule WhileT,simp)
apply(drule_tac P="While b P" in lift_is_cptn)
apply(simp add:lift_def)
--{* While2 *}
apply(rule CptnComp)
 apply(rule WhileT,simp)
apply(rule cptn_append_is_cptn)
  apply(drule_tac P="While b P" in lift_is_cptn)
  apply(simp add:lift_def)
 apply simp
apply(simp split: split_if_asm)
apply(frule_tac P="While b P" in last_lift)
 apply(rule last_fst_esp,simp add:last_length)
apply(simp add:Cons_lift lift_def split_def last_conv_nth)
done

theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
apply(rule iffI)
 apply(erule cptn_onlyif_cptn_mod)
apply(erule cptn_if_cptn_mod)
done

section {* Validity  of Correctness Formulas*}

subsection {* Validity for Component Programs. *}

type_synonym 'a rgformula =
  "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"

definition assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set" where
  "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"

definition comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set" where
  "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
               (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"

definition com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
                 ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45) where
  "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
   \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"

subsection {* Validity for Parallel Programs. *}

definition All_None :: "(('a com) option) list \<Rightarrow> bool" where
  "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"

definition par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set" where
  "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
             c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"

definition par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set" where
  "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
        c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
         (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"

definition par_com_validity :: "'a  par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
\<Rightarrow> 'a set \<Rightarrow> bool"  ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45) where
  "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
   \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"

subsection {* Compositionality of the Semantics *}

subsubsection {* Definition of the conjoin operator *}

definition same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"

definition same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"

definition same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"

definition compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
         (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
                       (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
         (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"

definition conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"  ("_ \<propto> _" [65,65] 64) where
  "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"

subsubsection {* Some previous lemmas *}

lemma list_eq_if [rule_format]:
  "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
  by (induct xs) auto

lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
apply(rule iffI)
 apply clarify
 apply(erule nth_equalityI)
 apply simp+
done

lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
  by (cases ys) simp_all

lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
  by (induct ys) simp_all

lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
  by (induct ys) simp_all

lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
  by (induct c1) auto

lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
  by (induct c2) auto

lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
  by (induct c1) auto

lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
  by (induct c2) auto

lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]

lemma prog_not_eq_in_ctran_aux:
  assumes c: "(P,s) -c\<rightarrow> (Q,t)"
  shows "P\<noteq>Q" using c
  by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto

lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
apply clarify
apply(drule prog_not_eq_in_ctran_aux)
apply simp
done

lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
apply(erule par_ctran.induct)
apply(drule prog_not_eq_in_ctran_aux)
apply clarify
apply(drule list_eq_if)
 apply simp_all
apply force
done

lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
apply clarify
apply(drule prog_not_eq_in_par_ctran_aux)
apply simp
done

lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
  by (force elim: cptn.cases)

lemma tl_zero[rule_format]:
  "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
  by (induct ys) simp_all

subsection {* The Semantics is Compositional *}

lemma aux_if [rule_format]:
  "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
  \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
   \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
apply(induct ys)
 apply(clarify)
 apply(rule ParCptnOne)
apply(clarify)
apply(simp add:conjoin_def compat_label_def)
apply clarify
apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in all_dupE,simp)
apply(erule disjE)
--{* first step is a Component step *}
 apply clarify
 apply simp
 apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
  apply(subgoal_tac "b=snd(clist!i!0)",simp)
   prefer 2
   apply(simp add: same_state_def)
   apply(erule_tac x=i in allE,erule impE,assumption,
         erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
  prefer 2
  apply(simp add:same_program_def)
  apply(erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
  apply(rule nth_equalityI,simp)
  apply clarify
  apply(case_tac "i=ia",simp,simp)
  apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
  apply(drule_tac t=i in not_sym,simp)
  apply(erule etranE,simp)
 apply(rule ParCptnComp)
  apply(erule ParComp,simp)
--{* applying the induction hypothesis *}
 apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
 apply(erule_tac x="snd (clist ! i ! 0)" in allE)
 apply(erule mp)
 apply(rule_tac x="map tl clist" in exI,simp)
 apply(rule conjI,clarify)
  apply(case_tac "i=ia",simp)
   apply(rule nth_tl_if)
     apply(force simp add:same_length_def length_Suc_conv)
    apply simp
   apply(erule allE,erule impE,assumption,erule tl_in_cptn)
   apply(force simp add:same_length_def length_Suc_conv)
  apply(rule nth_tl_if)
    apply(force simp add:same_length_def length_Suc_conv)
   apply(simp add:same_state_def)
   apply(erule_tac x=ia in allE, erule impE, assumption,
     erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
   apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
   apply(drule_tac t=i  in not_sym,simp)
   apply(erule etranE,simp)
  apply(erule allE,erule impE,assumption,erule tl_in_cptn)
  apply(force simp add:same_length_def length_Suc_conv)
 apply(simp add:same_length_def same_state_def)
 apply(rule conjI)
  apply clarify
  apply(case_tac j,simp,simp)
  apply(erule_tac x=ia in allE, erule impE, assumption,
        erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
  apply(force simp add:same_length_def length_Suc_conv)
 apply(rule conjI)
  apply(simp add:same_program_def)
  apply clarify
  apply(case_tac j,simp)
   apply(rule nth_equalityI,simp)
   apply clarify
   apply(case_tac "i=ia",simp,simp)
  apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
  apply(rule nth_equalityI,simp,simp)
  apply(force simp add:length_Suc_conv)
 apply(rule allI,rule impI)
 apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
 apply(erule disjE)
  apply clarify
  apply(rule_tac x=ia in exI,simp)
  apply(case_tac "i=ia",simp)
   apply(rule conjI)
    apply(force simp add: length_Suc_conv)
   apply clarify
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
   apply simp
   apply(case_tac j,simp)
    apply(rule tl_zero)
      apply(erule_tac x=l in allE, erule impE, assumption,
            erule_tac x=1 and P="\<lambda>j.  (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
      apply(force elim:etranE intro:Env)
     apply force
    apply force
   apply simp
   apply(rule tl_zero)
     apply(erule tl_zero)
      apply force
     apply force
    apply force
   apply force
  apply(rule conjI,simp)
   apply(rule nth_tl_if)
     apply force
    apply(erule_tac x=ia  in allE, erule impE, assumption,
          erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
    apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
    apply(drule_tac t=i  in not_sym,simp)
    apply(erule etranE,simp)
   apply(erule tl_zero)
    apply force
   apply force
  apply clarify
  apply(case_tac "i=l",simp)
   apply(rule nth_tl_if)
     apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
    apply simp
   apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption,erule impE,assumption)
   apply(erule tl_zero,force)
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
   apply(rule nth_tl_if)
     apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
    apply(erule_tac x=l  in allE, erule impE, assumption,
          erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
    apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
    apply(erule etranE,simp)
   apply(rule tl_zero)
    apply force
   apply force
  apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
 apply(rule disjI2)
 apply(case_tac j,simp)
  apply clarify
  apply(rule tl_zero)
    apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j\<in>etran" in allE,erule impE, assumption)
    apply(case_tac "i=ia",simp,simp)
    apply(erule_tac x=ia  in allE, erule impE, assumption,
    erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
    apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
    apply(force elim:etranE intro:Env)
   apply force
  apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
 apply simp
 apply clarify
 apply(rule tl_zero)
   apply(rule tl_zero,force)
    apply force
   apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
  apply force
 apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
--{* first step is an environmental step *}
apply clarify
apply(erule par_etran.cases)
apply simp
apply(rule ParCptnEnv)
apply(erule_tac x="Ps" in allE)
apply(erule_tac x="t" in allE)
apply(erule mp)
apply(rule_tac x="map tl clist" in exI,simp)
apply(rule conjI)
 apply clarify
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I ?s j) \<in> cptn" in allE,simp)
 apply(erule cptn.cases)
   apply(simp add:same_length_def)
   apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
  apply(simp add:same_state_def)
  apply(erule_tac x=i  in allE, erule impE, assumption,
   erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<in>etran" in allE,simp)
 apply(erule etranE,simp)
apply(simp add:same_state_def same_length_def)
apply(rule conjI,clarify)
 apply(case_tac j,simp,simp)
 apply(erule_tac x=i  in allE, erule impE, assumption,
       erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
 apply(rule tl_zero)
   apply(simp)
  apply force
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
apply(rule conjI)
 apply(simp add:same_program_def)
 apply clarify
 apply(case_tac j,simp)
  apply(rule nth_equalityI,simp)
  apply clarify
  apply simp
 apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
 apply(rule nth_equalityI,simp,simp)
 apply(force simp add:length_Suc_conv)
apply(rule allI,rule impI)
apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
apply(erule disjE)
 apply clarify
 apply(rule_tac x=i in exI,simp)
 apply(rule conjI)
  apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
  apply(erule etranE,simp)
  apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x=1 and P="\<lambda>j.  (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
  apply(rule nth_tl_if)
   apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
  apply simp
 apply(erule tl_zero,force)
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
 apply clarify
 apply(erule_tac x=l and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
 apply(erule etranE,simp)
 apply(erule_tac x=l  in allE, erule impE, assumption,
       erule_tac x=1 and P="\<lambda>j.  (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
 apply(rule nth_tl_if)
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
  apply simp
  apply(rule tl_zero,force)
  apply force
 apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
apply(rule disjI2)
apply simp
apply clarify
apply(case_tac j,simp)
 apply(rule tl_zero)
   apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
   apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
   apply(force elim:etranE intro:Env)
  apply force
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
apply simp
apply(rule tl_zero)
  apply(rule tl_zero,force)
   apply force
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
 apply force
apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
done

lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
  (\<exists>clist. (length clist = length xs) \<and>
  (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
  (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
apply(induct ys)
 apply(clarify)
 apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
 apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
 apply(rule conjI)
  apply(rule nth_equalityI,simp,simp)
 apply(force intro: cptn.intros)
apply(clarify)
apply(erule par_cptn.cases,simp)
 apply simp
 apply(erule_tac x="xs" in allE)
 apply(erule_tac x="t" in allE,simp)
 apply clarify
 apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
 apply(rule conjI)
  prefer 2
  apply clarify
  apply(rule CptnEnv,simp)
 apply(simp add:conjoin_def same_length_def same_state_def)
 apply (rule conjI)
  apply clarify
  apply(case_tac j,simp,simp)
 apply(rule conjI)
  apply(simp add:same_program_def)
  apply clarify
  apply(case_tac j,simp)
   apply(rule nth_equalityI,simp,simp)
  apply simp
  apply(rule nth_equalityI,simp,simp)
 apply(simp add:compat_label_def)
 apply clarify
 apply(case_tac j,simp)
  apply(simp add:ParEnv)
  apply clarify
  apply(simp add:Env)
 apply simp
 apply(erule_tac x=nat in allE,erule impE, assumption)
 apply(erule disjE,simp)
  apply clarify
  apply(rule_tac x=i in exI,simp)
 apply force
apply(erule par_ctran.cases,simp)
apply(erule_tac x="Ps[i:=r]" in allE)
apply(erule_tac x="ta" in allE,simp)
apply clarify
apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
apply(rule conjI)
 prefer 2
 apply clarify
 apply(case_tac "i=ia",simp)
  apply(erule CptnComp)
  apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<in> cptn)" in allE,simp)
 apply simp
 apply(erule_tac x=ia in allE)
 apply(rule CptnEnv,simp)
apply(simp add:conjoin_def)
apply (rule conjI)
 apply(simp add:same_length_def)
 apply clarify
 apply(case_tac "i=ia",simp,simp)
apply(rule conjI)
 apply(simp add:same_state_def)
 apply clarify
 apply(case_tac j, simp, simp (no_asm_simp))
 apply(case_tac "i=ia",simp,simp)
apply(rule conjI)
 apply(simp add:same_program_def)
 apply clarify
 apply(case_tac j,simp)
  apply(rule nth_equalityI,simp,simp)
 apply simp
 apply(rule nth_equalityI,simp,simp)
 apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (fst (?a j))=((?b j))" in allE)
 apply(case_tac nat)
  apply clarify
  apply(case_tac "i=ia",simp,simp)
 apply clarify
 apply(case_tac "i=ia",simp,simp)
apply(simp add:compat_label_def)
apply clarify
apply(case_tac j)
 apply(rule conjI,simp)
  apply(erule ParComp,assumption)
  apply clarify
  apply(rule_tac x=i in exI,simp)
 apply clarify
 apply(rule Env)
apply simp
apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in allE,simp)
apply(erule disjE)
 apply clarify
 apply(rule_tac x=ia in exI,simp)
 apply(rule conjI)
  apply(case_tac "i=ia",simp,simp)
 apply clarify
 apply(case_tac "i=l",simp)
  apply(case_tac "l=ia",simp,simp)
  apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
 apply simp
 apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
apply clarify
apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption)
apply(case_tac "i=ia",simp,simp)
done

lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
 (\<exists>clist. length clist= length xs \<and>
 ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
 (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
 (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
 (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
apply (rule iffI)
 apply(rule subset_antisym)
  apply(rule subsetI)
  apply(clarify)
  apply(simp add:par_cp_def cp_def)
  apply(case_tac x)
   apply(force elim:par_cptn.cases)
  apply simp
  apply(rename_tac a list)
  apply(erule_tac x="list" in allE)
  apply clarify
  apply simp
  apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
 apply(rule subsetI)
 apply(clarify)
 apply(case_tac x)
  apply(erule_tac x=0 in allE)
  apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
  apply clarify
  apply(erule cptn.cases,force,force,force)
 apply(simp add:par_cp_def conjoin_def  same_length_def same_program_def same_state_def compat_label_def)
 apply clarify
 apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in all_dupE)
 apply(subgoal_tac "a = xs")
  apply(subgoal_tac "b = s",simp)
   prefer 3
   apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=((?t j))" in allE)
   apply (simp add:cp_def)
   apply(rule nth_equalityI,simp,simp)
  prefer 2
  apply(erule_tac x=0 in allE)
  apply (simp add:cp_def)
  apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (\<forall>i. ?T i \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
  apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
 apply(erule_tac x=list in allE)
 apply(rule_tac x="map tl clist" in exI,simp)
 apply(rule conjI)
  apply clarify
  apply(case_tac j,simp)
   apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
  apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x="Suc nat" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
  apply(case_tac "clist!i",simp,simp)
 apply(rule conjI)
  apply clarify
  apply(rule nth_equalityI,simp,simp)
  apply(case_tac j)
   apply clarify
   apply(erule_tac x=i in allE)
   apply(simp add:cp_def)
  apply clarify
  apply simp
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
  apply(case_tac "clist!i",simp,simp)
 apply(thin_tac "?H = (\<exists>i. ?J i)")
 apply(rule conjI)
  apply clarify
  apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
   apply clarify
   apply(rule_tac x=i in exI,simp)
   apply(case_tac j,simp)
    apply(rule conjI)
     apply(erule_tac x=i in allE)
     apply(simp add:cp_def)
     apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
     apply(case_tac "clist!i",simp,simp)
    apply clarify
    apply(erule_tac x=l in allE)
    apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
    apply clarify
    apply(simp add:cp_def)
    apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
    apply(case_tac "clist!l",simp,simp)
   apply simp
   apply(rule conjI)
    apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
    apply(case_tac "clist!i",simp,simp)
   apply clarify
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
   apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
   apply(case_tac "clist!l",simp,simp)
  apply clarify
  apply(erule_tac x=i in allE)
  apply(simp add:cp_def)
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
  apply(case_tac "clist!i",simp)
  apply(rule nth_tl_if,simp,simp)
  apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption,simp)
  apply(simp add:cp_def)
  apply clarify
  apply(rule nth_tl_if)
   apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
   apply(case_tac "clist!i",simp,simp)
  apply force
 apply force
apply clarify
apply(rule iffI)
 apply(simp add:par_cp_def)
 apply(erule_tac c="(xs, s) # ys" in equalityCE)
  apply simp
  apply clarify
  apply(rule_tac x="map tl clist" in exI)
  apply simp
  apply (rule conjI)
   apply(simp add:conjoin_def cp_def)
   apply(rule conjI)
    apply clarify
    apply(unfold same_length_def)
    apply clarify
    apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,simp)
   apply(rule conjI)
    apply(simp add:same_state_def)
    apply clarify
    apply(erule_tac x=i in allE, erule impE, assumption,
       erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
    apply(case_tac j,simp)
    apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
    apply(case_tac "clist!i",simp,simp)
   apply(rule conjI)
    apply(simp add:same_program_def)
    apply clarify
    apply(rule nth_equalityI,simp,simp)
    apply(case_tac j,simp)
    apply clarify
    apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
    apply(case_tac "clist!i",simp,simp)
   apply clarify
   apply(simp add:compat_label_def)
   apply(rule allI,rule impI)
   apply(erule_tac x=j in allE,erule impE, assumption)
   apply(erule disjE)
    apply clarify
    apply(rule_tac x=i in exI,simp)
    apply(rule conjI)
     apply(erule_tac x=i in allE)
     apply(case_tac j,simp)
      apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
      apply(case_tac "clist!i",simp,simp)
     apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
     apply(case_tac "clist!i",simp,simp)
    apply clarify
    apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
    apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
    apply(case_tac "clist!l",simp,simp)
    apply(erule_tac x=l in allE,simp)
   apply(rule disjI2)
   apply clarify
   apply(rule tl_zero)
     apply(case_tac j,simp,simp)
     apply(rule tl_zero,force)
      apply force
     apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
    apply force
   apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
  apply clarify
  apply(erule_tac x=i in allE)
  apply(simp add:cp_def)
  apply(rule nth_tl_if)
    apply(simp add:conjoin_def)
    apply clarify
    apply(simp add:same_length_def)
    apply(erule_tac x=i in allE,simp)
   apply simp
  apply simp
 apply simp
apply clarify
apply(erule_tac c="(xs, s) # ys" in equalityCE)
 apply(simp add:par_cp_def)
apply simp
apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
apply simp
apply clarify
apply(simp add:cp_def)
done

theorem one: "xs\<noteq>[] \<Longrightarrow>
 par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
               (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
apply(frule one_iff_aux)
apply(drule sym)
apply(erule iffD2)
apply clarify
apply(rule iffI)
 apply(erule aux_onlyif)
apply clarify
apply(force intro:aux_if)
done

end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

header {* \isaheader{LBV for the JVM}\label{sec:JVM} *}

theory LBVJVM
imports "../DFA/Abstract_BV" TF_JVM
begin

type_synonym prog_cert = "cname \<Rightarrow> mname \<Rightarrow> ty\<^sub>i' err list"

definition check_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> bool"
where
  "check_cert P mxs mxl n cert \<equiv> check_types P mxs mxl cert \<and> size cert = n+1 \<and>
                                 (\<forall>i<n. cert!i \<noteq> Err) \<and> cert!n = OK None"

definition lbvjvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow>
             ty\<^sub>i' err list \<Rightarrow> instr list \<Rightarrow> ty\<^sub>i' err \<Rightarrow> ty\<^sub>i' err"
where
  "lbvjvm P mxs maxr T\<^sub>r et cert bs \<equiv>
  wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs T\<^sub>r et bs) 0"

definition wt_lbv :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> instr list \<Rightarrow> bool"
where
  "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et cert ins \<equiv>
   check_cert P mxs (1+size Ts+mxl\<^sub>0) (size ins) cert \<and>
   0 < size ins \<and>
   (let start  = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl\<^sub>0 Err));
        result = lbvjvm P mxs (1+size Ts+mxl\<^sub>0) T\<^sub>r et cert ins (OK start)
    in result \<noteq> Err)"

definition wt_jvm_prog_lbv :: "jvm_prog \<Rightarrow> prog_cert \<Rightarrow> bool"
where
  "wt_jvm_prog_lbv P cert \<equiv>
  wf_prog (\<lambda>P C (mn,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,b,et)). wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et (cert C mn) b) P"

definition mk_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow> instr list
              \<Rightarrow> ty\<^sub>m \<Rightarrow> ty\<^sub>i' err list"
where
  "mk_cert P mxs T\<^sub>r et bs phi \<equiv> make_cert (exec P mxs T\<^sub>r et bs) (map OK phi) (OK None)"

definition prg_cert :: "jvm_prog \<Rightarrow> ty\<^sub>P \<Rightarrow> prog_cert"
where
  "prg_cert P phi C mn \<equiv> let (C,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,ins,et)) = method P C mn
                         in  mk_cert P mxs T\<^sub>r et ins (phi C mn)"

lemma check_certD [intro?]:
  "check_cert P mxs mxl n cert \<Longrightarrow> cert_ok cert n Err (OK None) (states P mxs mxl)"
  by (unfold cert_ok_def check_cert_def check_types_def) auto

lemma (in start_context) wt_lbv_wt_step:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s \<in> list (size is) A. wt_step r Err step \<tau>s \<and> OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof -
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover note bounded_step
  moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover note exec_pres_type
  moreover
  from lbv
  have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])
  moreover note first_in_A
  moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
  ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
(*>*)

lemma (in start_context) wt_lbv_wt_method:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from lbv have l: "is \<noteq> []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C Ts obtain \<tau>s where
    list:  "\<tau>s \<in> list (size is) A" and
    step:  "wt_step r Err step \<tau>s" and
    start: "OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "size \<tau>s = size is" by simp
  have "size (map ok_val \<tau>s) = size is" by simp
  moreover from l have 0: "0 < size \<tau>s" by simp
  with step obtain \<tau>s0 where "\<tau>s!0 = OK \<tau>s0"
    by (unfold wt_step_def) blast
  with start 0 have "wt_start P C Ts mxl\<^sub>0 (map ok_val \<tau>s)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)
  moreover {
    from list have "check_types P mxs mxl \<tau>s" by (simp add: check_types_def)
    also from step  have "\<forall>x \<in> set \<tau>s. x \<noteq> Err"
      by (auto simp add: all_set_conv_all_nth wt_step_def)
    hence [symmetric]: "map OK (map ok_val \<tau>s) = \<tau>s"
      by (auto intro!: map_idI)
    finally have "check_types P mxs mxl (map OK (map ok_val \<tau>s))" .
  }
  moreover {
    note bounded_step
    moreover from list have "set \<tau>s \<subseteq> A" by simp
    moreover from step have "wt_err_step (sup_state_opt P) step \<tau>s"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
  }
  ultimately have "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s)"
    by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis ..
qed
(*>*)

lemma (in start_context) wt_method_wt_lbv:
  assumes wt: "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  defines [simp]: "cert \<equiv> mk_cert P mxs T\<^sub>r xt is \<tau>s"

  shows "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
(*<*)
proof -
  let ?\<tau>s  = "map OK \<tau>s"
  let ?cert = "make_cert step ?\<tau>s (OK None)"

  from wt obtain
    0:        "0 < size is" and
    size:     "size is = size ?\<tau>s" and
    ck_types: "check_types P mxs mxl ?\<tau>s" and
    wt_start: "wt_start P C Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (force simp add: wt_method_def2 check_types_def)

  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover from wf have "mono r step (size is) A" by (rule step_mono)
  hence "mono r step (size ?\<tau>s) A" by (simp add: size)
  moreover from exec_pres_type
  have "pres_type step (size ?\<tau>s) A" by (simp add: size)
  moreover
  from ck_types have \<tau>s_in_A: "set ?\<tau>s \<subseteq> A" by (simp add: check_types_def)
  hence "\<forall>pc. pc < size ?\<tau>s \<longrightarrow> ?\<tau>s!pc \<in> A \<and> ?\<tau>s!pc \<noteq> Err" by auto
  moreover from bounded_step
  have "bounded step (size ?\<tau>s)" by (simp add: size)
  moreover have "OK None \<noteq> Err" by simp
  moreover from bounded_step size \<tau>s_in_A app_eff
  have "wt_err_step (sup_state_opt P) step ?\<tau>s"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)
  hence "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  from 0 size have "0 < size \<tau>s" by auto
  hence "?\<tau>s!0 = OK (\<tau>s!0)" by simp
  with wt_start have "OK first \<sqsubseteq>\<^sub>r ?\<tau>s!0"
    by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
  moreover note first_in_A
  moreover have "OK first \<noteq> Err" by simp
  moreover note size
  ultimately
  have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover from 0 size have "\<tau>s \<noteq> []" by auto
  moreover from ck_types have "check_types P mxs mxl ?cert"
    by (auto simp add: make_cert_def check_types_def JVM_states_unfold)
  moreover note 0 size
  ultimately show ?thesis
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
                  check_cert_def make_cert_def nth_append)
qed
(*>*)

theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv P Cert \<Longrightarrow> wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C mn. let (C,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C mn in
              SOME \<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"

  assume wt: "wt_jvm_prog_lbv P Cert"
  hence "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P"
    apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
    apply (erule wf_prog_lift)
    apply (auto dest!: start_context.wt_lbv_wt_method [OF start_context.intro]
                intro: someI)
    apply (erule sees_method_is_class)
    done
  thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
(*>*)

theorem jvm_lbv_complete:
  assumes wt: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  shows "wt_jvm_prog_lbv P (prg_cert P \<Phi>)"
(*<*)
  using wt
  apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
  apply (erule wf_prog_lift)
  apply (auto simp add: prg_cert_def
              intro!: start_context.wt_method_wt_lbv start_context.intro)
  apply (erule sees_method_is_class)
  done
(*>*)

end


theory IOTickTock_Prefix
  imports IOTickTock_Core
begin

definition PrefixIOTT :: "'e \<Rightarrow> 'e set \<Rightarrow> 'e ttprocess \<Rightarrow> 'e ttprocess" (infixr "\<rightarrow>\<^sub>C\<^bsup>_\<^esup>" 61) where
  "PrefixIOTT e Outs P =
    {t. \<exists> s\<in>tocks({x. x \<noteq> Tock \<and> x \<noteq> Event e}). e \<notin> Outs \<and> (t = s \<or> (\<exists> X. Tock \<notin> X \<and> Event e \<notin> X \<and> t = s @ [[X]\<^sub>R]))}
     \<union> {t. \<exists> s\<in>tocks({x. x \<noteq> Tock \<and> x \<noteq> Event e}). e \<notin> Outs \<and> (t = s \<or> (\<exists> \<sigma>\<in>P. t = s @ [[Event e]\<^sub>E] @ \<sigma>))}
     \<union> {t. ((\<exists> \<sigma>\<in>P. t = [[Event e]\<^sub>E] @ \<sigma>) \<or> t = []) \<and> e \<in> Outs}"

lemma PrefixIOTT_input_eq_PrefixTT:
  "e \<notin> Outs \<Longrightarrow> (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P) = (e \<rightarrow>\<^sub>C P)"
  unfolding PrefixTT_def PrefixIOTT_def by auto

lemma "\<forall>x\<in>P. ttWF x \<Longrightarrow> \<forall> x \<in> e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P. ttWF x"
proof (cases "e \<in> Outs")
  assume "e \<in> Outs"
  then show "\<forall>x\<in>P. ttWF x \<Longrightarrow> \<forall>x\<in>e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P. ttWF x"
    unfolding PrefixIOTT_def by auto
next
  assume "e \<notin> Outs"
  then show "\<forall>x\<in>P. ttWF x \<Longrightarrow> \<forall>x\<in>e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P. ttWF x"
    by (simp add: PrefixIOTT_input_eq_PrefixTT PrefixTT_wf)
qed

lemma TT0_PrefixIOTT:
  "TT0 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
proof (cases "e \<in> Outs")
  assume "e \<in> Outs"
  then show "TT0 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    unfolding PrefixIOTT_def TT0_def by auto
next
  assume "e \<notin> Outs"
  then show "TT0 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    using PrefixIOTT_input_eq_PrefixTT PrefixTT_def TT0_def tocks.empty_in_tocks by fastforce
qed

lemma TT1_PrefixIOTT:
  "TT1 P \<Longrightarrow> TT1 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
proof (cases "e \<in> Outs")
  assume "e \<in> Outs"
  then show "TT1 P \<Longrightarrow> TT1 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    unfolding PrefixIOTT_def TT1_def apply auto
    apply (metis add_Tick_refusal_trace.cases tt_prefix_subset.simps(3) tt_prefix_subset.simps(5))
    using tt_prefix_subset.elims(2) by blast
next
  assume "e \<notin> Outs"
  then show "TT1 P \<Longrightarrow> TT1 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    by (simp add: PrefixIOTT_input_eq_PrefixTT TT1_Prefix)
qed

lemma TT2_PrefixIOTT:
  assumes "TT0 P" "TT1 P" "TT2 P"
  shows "TT2 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
proof (cases "e \<in> Outs")
  assume "e \<in> Outs"
  then show "TT2 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    unfolding PrefixIOTT_def TT2_def
  proof auto
    fix \<rho> \<sigma> X Y \<sigma>'
    assume case_assms: "Y \<inter> {ea. ea \<noteq> Tock \<and> (\<exists>\<sigma>\<in>P. \<rho> @ [[ea]\<^sub>E] = [Event e]\<^sub>E # \<sigma>)
        \<or> ea = Tock \<and> (\<exists>\<sigma>\<in>P. \<rho> @ [[X]\<^sub>R, [ea]\<^sub>E] = [Event e]\<^sub>E # \<sigma>)} = {}"
      "\<sigma>' \<in> P" "\<rho> @ [X]\<^sub>R # \<sigma> = [Event e]\<^sub>E # \<sigma>'"
    obtain \<rho>' where \<rho>'_def: "\<rho> = [Event e]\<^sub>E # \<rho>'"
      using case_assms(3) by (induct \<rho> rule:ttWF.induct, auto)
    have "\<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
      using  \<rho>'_def case_assms assms unfolding TT2_def by auto
    then show "\<exists>\<sigma>'\<in>P. \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> = [Event e]\<^sub>E # \<sigma>'"
      by (simp add: \<rho>'_def)
  qed
next
  assume "e \<notin> Outs"
  then show "TT2 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    using assms by (simp add: PrefixIOTT_input_eq_PrefixTT TT2_Prefix)
qed

lemma TT3_PrefixIOTT:
  assumes "TT1 P" "TT3 P"
  shows "TT3 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
proof (cases "e \<in> Outs")
  assume "e \<in> Outs"
  then show "TT3 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    unfolding PrefixIOTT_def TT3_def
  proof auto
    fix \<rho> \<sigma> X \<sigma>'
    assume case_assms: "e \<in> Outs" "\<sigma>' \<in> P" "\<rho> @ [X]\<^sub>R # \<sigma> = [Event e]\<^sub>E # \<sigma>'"
    obtain \<rho>' where \<rho>'_def: "\<rho> = [Event e]\<^sub>E # \<rho>'"
      using case_assms(3) by (induct \<rho> rule:ttWF.induct, auto)
    have "\<rho>' @ [insert Tick X]\<^sub>R # \<sigma> \<in> P"
      using  \<rho>'_def case_assms assms unfolding TT3_def by auto
    then show "\<exists>\<sigma>'\<in>P. \<rho> @ [insert Tick X]\<^sub>R # \<sigma> = [Event e]\<^sub>E # \<sigma>'"
      by (simp add: \<rho>'_def)
  qed
next
  assume "e \<notin> Outs"
  then show "TT3 (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
    by (simp add: PrefixIOTT_input_eq_PrefixTT TT3_Prefix assms)
qed

lemma IOTT0_PrefixIOTT:
  "IOTT0 Outs P \<Longrightarrow> IOTT0 Outs (e \<rightarrow>\<^sub>C\<^bsup>Outs\<^esup> P)"
  unfolding IOTT0_def PrefixIOTT_def
proof auto
  fix s
  assume case_assms: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}" "e \<notin> Outs"
  then have "IOTT0_trace Outs s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    apply - apply (induct s rule:tocks.induct, auto)
    using tocks.empty_in_tocks apply blast
    using tocks.simps by fastforce
  then show "\<forall>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}.
            IOTT0_trace Outs s \<noteq> sa \<and> (\<forall>\<sigma>\<in>P. IOTT0_trace Outs s \<noteq> sa @ [Event e]\<^sub>E # \<sigma>) \<Longrightarrow>
         \<exists>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> IOTT0_trace Outs s = sa @ [[X]\<^sub>R]"
    by auto
next
  fix s X
  assume case_assms: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}" "e \<notin> Outs" "Tock \<notin> X" "Event e \<notin> X"
  then have "IOTT0_trace Outs s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    apply - apply (induct s rule:tocks.induct, auto)
    using tocks.empty_in_tocks apply blast
    using tocks.simps by fastforce
  then show "\<exists>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}.
              \<exists>Xa. Tock \<notin> Xa \<and> Event e \<notin> Xa \<and> IOTT0_trace Outs (s @ [[X]\<^sub>R]) = sa @ [[Xa]\<^sub>R]"
    apply (rule_tac x="IOTT0_trace Outs s" in bexI, simp_all)
    by (rule_tac x="X \<union> Event ` Outs" in exI, auto simp add: case_assms IOTT0_trace_append_refusal)
next
  fix s
  assume case_assms: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}" "e \<notin> Outs"
  then have "IOTT0_trace Outs s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    apply - apply (induct s rule:tocks.induct, auto)
    using tocks.empty_in_tocks apply blast
    using tocks.simps by fastforce
  then show "\<forall>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}.
            IOTT0_trace Outs s \<noteq> sa \<and> (\<forall>\<sigma>\<in>P. IOTT0_trace Outs s \<noteq> sa @ [Event e]\<^sub>E # \<sigma>) \<Longrightarrow>
         \<exists>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> IOTT0_trace Outs s = sa @ [[X]\<^sub>R]"
    by auto
next
  fix s \<sigma>
  assume case_assms: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}" "e \<notin> Outs" "\<sigma> \<in> P"
    "\<forall>x. x \<in> P \<longrightarrow> IOTT0_trace Outs x \<in> P"
  then have "IOTT0_trace Outs s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    apply - apply (induct s rule:tocks.induct, auto)
    using tocks.empty_in_tocks apply blast
    using tocks.simps by fastforce
  also have "IOTT0_trace Outs \<sigma> \<in> P"
    using case_assms(3) case_assms(4) by blast
  then show "\<forall>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. IOTT0_trace Outs (s @ [Event e]\<^sub>E # \<sigma>) \<noteq> sa \<and>
              (\<forall>\<sigma>'\<in>P. IOTT0_trace Outs (s @ [Event e]\<^sub>E # \<sigma>) \<noteq> sa @ [Event e]\<^sub>E # \<sigma>') \<Longrightarrow>
           \<exists>sa\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}.
              \<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> IOTT0_trace Outs (s @ [Event e]\<^sub>E # \<sigma>) = sa @ [[X]\<^sub>R]"
    using calculation apply (erule_tac x="IOTT0_trace Outs s" in ballE, auto)
    by (erule_tac x="IOTT0_trace Outs \<sigma>" in ballE, auto simp add: IOTT0_trace_append)
qed

end