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

lemma tauPres:
  fixes P    :: pi
  and   Q    :: pi
  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 a y Q')
  have "\<tau>.(Q) \<longmapsto> a<\<nu>y> \<prec> Q'" by fact
  hence False by(induct rule: tauCases', auto)
  thus ?case by simp
next
  case(Free \<alpha> Q')
  have "\<tau>.(Q) \<longmapsto> \<alpha> \<prec> Q'" by fact
  thus "\<exists>P'. \<tau>.(P) \<longmapsto> \<alpha>  \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: tauCases', auto simp add: pi.inject residual.inject)
    have "\<tau>.(P) \<longmapsto> \<tau> \<prec> P" by(rule TransitionsEarly.Tau)
    with PRelQ show "\<exists>P'. \<tau>.(P) \<longmapsto> \<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 \<open>y \<sharp> (x, a, P, Q)\<close> have "y \<noteq> x" "y \<noteq> a" "y \<sharp> P" "y \<sharp> Q" by simp+
  from \<open>a<x>.Q \<longmapsto>b<\<nu>y> \<prec> Q'\<close> \<open>y \<noteq> a\<close> \<open>y \<noteq> x\<close> \<open>y \<sharp> Q\<close> show ?case
    by(erule_tac inputCases') auto
next
  case(Free \<alpha> Q')
  from \<open>a<x>.Q \<longmapsto> \<alpha> \<prec> Q'\<close>
  show ?case
  proof(induct rule: inputCases)
    case(cInput u)
    have "a<x>.P \<longmapsto>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"
  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 c y Q')
  have "a{b}.Q \<longmapsto> c<\<nu>y> \<prec> Q'" by fact
  hence False by(induct rule: outputCases', auto)
  thus "\<exists>P'. a{b}.P \<longmapsto> c<\<nu>y> \<prec> P' \<and> (P', Q') \<in> Rel" by simp
next
  case(Free \<alpha> Q')
  have "a{b}.Q \<longmapsto> \<alpha> \<prec> Q'" by fact
  thus "\<exists>P'. a{b}.P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: outputCases', auto simp add: pi.inject residual.inject)
    have "a{b}.P \<longmapsto> a[b] \<prec> P" by(rule TransitionsEarly.Output)
    with PRelQ show "\<exists>P'. a{b}.P \<longmapsto> a[b] \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

  assumes PSimQ: "P \<leadsto>[Rel] Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  shows "[a\<frown>b]P \<leadsto>[Rel'] [a\<frown>b]Q"
proof(induct rule: simCases)
  case(Bound c y Q')
  have "(y::name) \<sharp> [a\<frown>b]P" by fact
  hence yFreshP: "y \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto> c<\<nu>y> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto>c<\<nu>y> \<prec> Q'" by fact
    with PSimQ yFreshP obtain P' where PTrans: "P \<longmapsto>c<\<nu>y> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "[a\<frown>a]P \<longmapsto> c<\<nu>y> \<prec> P'" by(rule Early_Semantics.Match)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free \<alpha> Q')
  assume "[a\<frown>b]Q \<longmapsto> \<alpha> \<prec> Q'"
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<longmapsto> \<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "[a\<frown>a]P \<longmapsto>\<alpha> \<prec> P'" by(rule TransitionsEarly.Match)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  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'"

  shows "[a\<noteq>b]P \<leadsto>[Rel'] [a\<noteq>b]Q"
proof(cases "a = b")
  assume "a = b"
  thus ?thesis
    by(auto simp add: strongSimEarly_def)
next
  assume aineqb: "a \<noteq> b"
  show ?thesis
  proof(induct rule: simCases)
    case(Bound c x Q')
    have "x \<sharp> [a\<noteq>b]P" by fact
    hence xFreshP: "x \<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 "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
      with PSimQ xFreshP obtain P' where PTrans: "P \<longmapsto>c<\<nu>x> \<prec> P'"
                                     and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: elim)

      from PTrans aineqb have "[a\<noteq>b]P \<longmapsto> c<\<nu>x> \<prec> P'" by(rule Early_Semantics.Mismatch)
      moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
      ultimately show ?case by blast
    qed
  next
    case(Free \<alpha> Q')
    have "[a\<noteq>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: mismatchCases)
      case Mismatch
      have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<longmapsto> \<alpha> \<prec> P'"
                             and PRel: "(P', Q') \<in> Rel"
          by(blast dest: elim)
      from PTrans \<open>a \<noteq> b\<close> have "[a\<noteq>b]P \<longmapsto>\<alpha> \<prec> P'" by(rule TransitionsEarly.Mismatch)
      with RelRel' PRel show ?case by blast
    qed
  qed
qed

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

  assumes "P \<leadsto>[Rel] Q"
  and     C1: "Id \<subseteq> Rel'"
  and     "Rel \<subseteq> Rel'"

  shows "P \<oplus> R \<leadsto>[Rel'] Q \<oplus> R"
proof(induct rule: simCases)
  case(Bound a y Q')
  have "y \<sharp> P \<oplus> R" by fact
  hence "(y::name) \<sharp> P" and  "y \<sharp> R" by simp+
  from \<open>Q \<oplus> R \<longmapsto>a<\<nu>y> \<prec> Q'\<close> show ?case
  proof(induct rule: sumCases)
    case Sum1
    from \<open>P \<leadsto>[Rel] Q\<close> \<open>Q \<longmapsto>a<\<nu>y> \<prec> Q'\<close> \<open>y \<sharp> P\<close> obtain P' where PTrans: "P \<longmapsto>a<\<nu>y> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "P \<oplus> R \<longmapsto>a<\<nu>y> \<prec> P'" by(rule Early_Semantics.Sum1)
    moreover from P'RelQ' \<open>Rel \<subseteq> Rel'\<close> have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  next
    case Sum2
    from \<open>R \<longmapsto>a<\<nu>y> \<prec> Q'\<close> have "P \<oplus> R \<longmapsto>a<\<nu>y> \<prec> Q'" by(rule Early_Semantics.Sum2)
    moreover from C1 have "(Q', Q') \<in> Rel'" by auto
    ultimately show ?case by blast
  qed
next
  case(Free \<alpha> Q')
  from \<open>Q \<oplus> R \<longmapsto>\<alpha> \<prec> Q'\<close> show "\<exists>P'. P \<oplus> R \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
  proof(induct rule: sumCases)
    case Sum1
    have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    with \<open>P \<leadsto>[Rel] Q\<close> obtain P' where PTrans: "P \<longmapsto>\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "P \<oplus> R \<longmapsto>\<alpha> \<prec> P'" by(rule TransitionsEarly.Sum1)
    moreover from P'RelQ' \<open>Rel \<subseteq> Rel'\<close> have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  next
    case Sum2
    from \<open>R \<longmapsto>\<alpha> \<prec> Q'\<close> have "P \<oplus> R \<longmapsto>\<alpha> \<prec> Q'" by(rule TransitionsEarly.Sum2)
    moreover from C1 have "(Q', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
qed

lemma parCompose:
  fixes P     :: pi
  and   Q     :: pi
  and   R     :: pi
  and   T     :: 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>S T x. (S, T) \<in> Rel'' \<Longrightarrow> (<\<nu>x>S, <\<nu>x>T) \<in> Rel''"

  shows "P \<parallel> R \<leadsto>[Rel''] Q \<parallel> S"
proof(induct rule: simCases)
  case(Bound a x Q')
  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 "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans:"P \<longmapsto> a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans xFreshR have "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Early_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 "S \<longmapsto> a<\<nu>x> \<prec> S'" by fact
    with RSimT xFreshR obtain R' where RTrans:"R \<longmapsto> a<\<nu>x> \<prec> R'" and R'Rel'T': "(R', S') \<in>  Rel'"
      by(blast dest: elim)

    from RTrans xFreshP have ParTrans: "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P \<parallel> R')" by(rule Early_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 \<alpha> QT')
  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 \<longmapsto> \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<parallel> R" by(rule Early_Semantics.Par1F)
    moreover from PRel RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(rule 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 \<longmapsto> \<alpha> \<prec> R'" and RRel: "(R', S') \<in> Rel'"
      by(blast dest: elim)

    from RTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P \<parallel> R'" by(rule Early_Semantics.Par2F)
    moreover from PRelQ RRel have "(P \<parallel> R', Q \<parallel> S') \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cComm1 Q' S' a b)
    have "Q \<longmapsto> a<b> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<longmapsto>a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    have "S \<longmapsto> a[b] \<prec> S'" by fact
    with RSimT obtain R' where RTrans: "R \<longmapsto>a[b] \<prec> R'" and RRel: "(R', S') \<in> Rel'"
      by(blast dest: elim)

    from PTrans RTrans have "P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<parallel> R'" by(rule Early_Semantics.Comm1)
    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 "Q \<longmapsto> (OutputR a b) \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<longmapsto>a[b] \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: elim)

    have "S \<longmapsto> a<b> \<prec> S'" by fact
    with RSimT obtain R' where RTrans: "R \<longmapsto>a<b> \<prec> R'" and R'Rel'T': "(R', S') \<in> Rel'"
      by(blast dest: elim)

    from PTrans RTrans have "P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<parallel> R'" by(rule Early_Semantics.Comm2)
    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 "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+

    have "Q \<longmapsto> a<x> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<longmapsto>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    have "S \<longmapsto> a<\<nu>x> \<prec> S'" by fact
    with RSimT xFreshR obtain R' where RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" and R'Rel'T': "(R', S') \<in> Rel'"
      by(blast dest: elim)

    from PTrans RTrans xFreshP have "P \<parallel> R \<longmapsto> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
      by(rule Early_Semantics.Close1)
    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 "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+

    have "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<longmapsto>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    have "S \<longmapsto> a<x> \<prec> S'" by fact
    with RSimT obtain R' where RTrans: "R \<longmapsto>a<x> \<prec> R'" and R'Rel'T': "(R', S') \<in> Rel'"
      by(blast dest: elim)

    from PTrans RTrans xFreshR have "P \<parallel> R \<longmapsto> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
      by(rule Early_Semantics.Close2)
    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

lemma parPres:
  fixes P   :: pi
  and   Q   :: pi
  and   R   :: 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     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     ResSet: "\<And>(R::pi) (S::pi) (y::name). (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::pi)" by simp+
    from Trans yineqx show ?case
    proof(induct rule: resCasesB)
      case(Open Q')
      have QTrans: "Q \<longmapsto>(a::name)[x] \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<longmapsto> a[x] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: elim)

      have "<\<nu>x>P \<longmapsto>a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
      proof -
        have aineqx: "a \<noteq> x" by fact
        with PTrans have "<\<nu>x>P \<longmapsto>a<\<nu>x> \<prec> P'" by(rule TransitionsEarly.Open)
        moreover have "a<\<nu>x> \<prec> P' = a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
        proof -
          from PTrans yFreshP have yFreshP': "y \<sharp> P'" by(force intro: freshTransition)
          thus ?thesis by(simp add: alphaBoundOutput name_swap)
        qed
        ultimately show ?thesis by simp
      qed
      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'" by fact

      with PSimQ yFreshP obtain P' where PTrans: "P \<longmapsto>a<\<nu>y> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: elim)

      have xineqa: "x \<noteq> a" by fact
      with PTrans yineqx have ResTrans: "<\<nu>x>P \<longmapsto>a<\<nu>y> \<prec> (<\<nu>x>P')"
        by(blast intro: ResB)
      moreover from P'RelQ' have "((<\<nu>x>P'), (<\<nu>x>Q')) \<in> Rel'"
        by(rule ResSet)

      ultimately show "\<exists>P'. <\<nu>x>P \<longmapsto> a<\<nu>y> \<prec> P' \<and> (P', (<\<nu>x>Q')) \<in> Rel'" by blast
    qed
  next
    case(Free \<alpha> Q')
    have Trans: "<\<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) \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
    proof -
      from Trans cFreshQ have "<\<nu>c>([(x, c)] \<bullet> Q) \<longmapsto>\<alpha> \<prec> Q'" by(simp add: alphaRes)
      moreover from EqvtRel PSimQ have "([(x, c)] \<bullet> P) \<leadsto>[Rel] ([(x, c)] \<bullet> Q)"
        by(blast intro: eqvtI)
      ultimately show ?thesis using cFreshAlpha
        apply -
        apply(erule resCasesF)
        apply auto
        by(blast intro: ResF ResSet dest: elim)
    qed

    ultimately show "\<exists>P'.<\<nu>x>P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" by auto
  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 x. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>x>R, <\<nu>x>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

  shows "!P \<leadsto>[bangRel 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 \<longmapsto>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> bangRel Rel)) \<and>
                     (\<forall>\<alpha> Q'. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> bangRel Rel))"
  from eqvtRel have EqvtBangRel: "eqvt(bangRel Rel)" by(rule eqvtBangRel)

  {
    fix Pa Rs
    assume "!Q \<longmapsto> Rs" and "(Pa, !Q) \<in> bangRel Rel"
    hence "?Sim Pa Rs" using PRelQ
    proof(nominal_induct avoiding: Pa P rule: bangInduct)
      case(Par1B a x Q' Pa P)
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> Pa" by fact+
      thus "?Sim Pa (a<\<nu>x> \<prec> (Q' \<parallel> !Q))"
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" by fact
        have PBRQ: "(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 alpha')
          from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)

          with QTrans xFreshP obtain P' where PTrans: "P \<longmapsto> a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

          from PTrans xFreshR have "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P' \<parallel> R)"
            by(force intro: Early_Semantics.Par1B)
          moreover from P'RelQ' PBRQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto>a<\<nu>x> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> bangRel Rel" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q'" and "y \<sharp> P" and "y \<sharp> R" and "y \<sharp> Q"
          from QTrans \<open>y \<sharp> Q'\<close> have "Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q')"
            by(simp add: alphaBoundOutput)
          moreover from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)
          ultimately obtain P' where PTrans: "P \<longmapsto>a<\<nu>y> \<prec> P'" and P'RelQ': "(P', [(x, y)] \<bullet> Q') \<in> Rel"
            using \<open>y \<sharp> P\<close>
            by(blast dest: elim)
          from PTrans \<open>y \<sharp> R\<close> have "P \<parallel> R \<longmapsto>a<\<nu>y> \<prec> (P' \<parallel> R)" by(force intro: Early_Semantics.Par1B)
          moreover from P'RelQ' PBRQ have "(P' \<parallel> R, ([(x, y)] \<bullet> Q') \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
          with \<open>x \<sharp> Q\<close> \<open>y \<sharp> Q\<close> have "(P' \<parallel> R, ([(y, x)] \<bullet> Q') \<parallel> !([(y, x)] \<bullet> Q)) \<in> bangRel Rel"
            by(simp add: name_fresh_fresh name_swap)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto>a<\<nu>y> \<prec> P' \<and> (P', ([(y, x)] \<bullet> Q') \<parallel> !([(y, x)] \<bullet> Q)) \<in> bangRel Rel"
            by blast
        qed
      qed
    next
      case(Par1F \<alpha> Q' Pa P)
      have QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      have "(Pa, 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 BR: "(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 \<longmapsto> \<alpha> \<prec> P'" and RRel: "(P', Q') \<in> Rel"
            by(blast dest: elim)

          from PTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<parallel> R" by(rule TransitionsEarly.Par1F)
          moreover from RRel BR have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Par2B a x Q' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a<\<nu>x> \<prec> Q')" by simp
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> Pa" by fact+
      thus "?Sim Pa (a<\<nu>x> \<prec> (Q \<parallel> Q'))"
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(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 EqvtBangRel show "?Sim (P \<parallel> R) (a<\<nu>x> \<prec> (Q \<parallel> Q'))"
        proof(auto simp add: residual.inject alpha')
          from RBRQ have "?Sim R (a<\<nu>x> \<prec> Q')" by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<longmapsto> a<\<nu>x> \<prec> R'" and R'BRQ': "(R', Q') \<in> (bangRel Rel)"
            by(metis elim)
          from RTrans xFreshP have "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P \<parallel> R')" by(auto intro: Early_Semantics.Par2B)
          moreover from PRelQ R'BRQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> (bangRel Rel)" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> bangRel Rel" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q" and "y \<sharp> Q'" and "y \<sharp> P" and "y \<sharp> R"
          from RBRQ have "?Sim R (a<\<nu>x> \<prec> Q')" by(rule IH)
          with \<open>y \<sharp> Q'\<close> have "?Sim R (a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q'))" by(simp add: alphaBoundOutput)
          with \<open>y \<sharp> R\<close> obtain R' where RTrans: "R \<longmapsto> a<\<nu>y> \<prec> R'" and R'BRQ': "(R', ([(x, y)] \<bullet> Q')) \<in> (bangRel Rel)"
            by(metis elim)
          from RTrans \<open>y \<sharp> P\<close> have "P \<parallel> R \<longmapsto> a<\<nu>y> \<prec> (P \<parallel> R')" by(auto intro: Early_Semantics.Par2B)
          moreover from PRelQ R'BRQ' have "(P \<parallel> R', Q \<parallel> ([(x, y)] \<bullet> Q')) \<in> (bangRel Rel)" by(rule Rel.BRPar)
          with \<open>y \<sharp> Q\<close> \<open>x \<sharp> Q\<close> have "(P \<parallel> R', ([(y, x)] \<bullet> Q) \<parallel> ([(y, x)] \<bullet> Q')) \<in> (bangRel Rel)"
            by(simp add: name_swap name_fresh_fresh)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> a<\<nu>y> \<prec> P' \<and> (P', ([(y, x)] \<bullet> Q) \<parallel> ([(y, x)] \<bullet> Q')) \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Par2F \<alpha> Q' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (\<alpha> \<prec> Q')" by simp
      have "(Pa, 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 RBRQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from RBRQ IH have "\<exists>R'. R \<longmapsto> \<alpha> \<prec> R' \<and> (R', Q') \<in> bangRel Rel"
            by(metis elim)
          then obtain R' where RTrans: "R \<longmapsto> \<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> bangRel Rel"
            by blast

          from RTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P \<parallel> R'" by(rule TransitionsEarly.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show " \<exists>P'. P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Comm1 a Q' b Q'' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a[b] \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto>a<b> \<prec> Q'" by fact
      have "(Pa, 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 RBRQ: "(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 \<longmapsto> a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

          from IH RBRQ have RTrans: "\<exists>R'. R \<longmapsto> a[b] \<prec> R' \<and> (R', Q'') \<in> bangRel Rel"
            by(metis elim)
          then obtain R' where RTrans: "R \<longmapsto> a[b] \<prec> R'" and R'RelQ'': "(R', Q'') \<in> bangRel Rel"
            by blast

          from PTrans RTrans have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule TransitionsEarly.Comm1)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', Q' \<parallel> Q'') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Comm2 a b Q' Q'')
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a<b> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a[b] \<prec> Q'" by fact
      have "(Pa, 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 RBRQ: "(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 \<longmapsto> a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

          from IH RBRQ have RTrans: "\<exists>R'. R \<longmapsto> a<b> \<prec> R' \<and> (R', Q'') \<in> bangRel Rel"
            by(metis elim)
          then obtain R' where RTrans: "R \<longmapsto> a<b> \<prec> R'" and R'RelQ'': "(R', Q'') \<in> bangRel Rel"
            by blast

          from PTrans RTrans have "P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<parallel> R'" by(rule TransitionsEarly.Comm2)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', Q' \<parallel> Q'') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Close1 a x Q' Q'' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<longrightarrow> ?Sim Pa (a<\<nu>x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have xFreshQ: "x \<sharp> Q" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      moreover have xFreshPa: "x \<sharp> Pa" by fact
      ultimately show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(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 \<longmapsto>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
             by(blast dest: elim)

           from RBRQ xFreshR IH have "\<exists>R'. R \<longmapsto>a<\<nu>x> \<prec> R' \<and> (R', Q'') \<in> bangRel Rel"
             by(metis elim)
           then obtain R' where RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" and R'RelQ'': "(R', Q'') \<in> bangRel Rel"
             by blast

           from PTrans RTrans xFreshP have "P \<parallel> R \<longmapsto>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
             by(rule Early_Semantics.Close1)
           moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> bangRel Rel"
             by(force intro: Rel.BRPar BRRes)
           ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> bangRel Rel" by blast
         qed
      qed
    next
      case(Close2 a x Q' Q'' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a<x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have xFreshQ: "x \<sharp> Q" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> Pa" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(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 \<longmapsto>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

          from RBRQ IH have "\<exists>R'.  R \<longmapsto>a<x> \<prec> R' \<and> (R', Q'') \<in> bangRel Rel"
            by auto
          then obtain R' where RTrans: "R \<longmapsto> a<x> \<prec> R'" and R'RelQ'': "(R', Q'') \<in> bangRel Rel"
            by blast

          from PTrans RTrans xFreshR have "P \<parallel> R \<longmapsto> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
            by(rule Early_Semantics.Close2)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> bangRel Rel"
            by(force intro: Rel.BRPar BRRes)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Bang Rs Pa P)
      hence IH: "\<And>Pa. (Pa, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa Rs" by simp
      have "(Pa, !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 BRPar)
        with IH have "?Sim (P \<parallel> !P) Rs" by simp
        thus ?case by(force intro: TransitionsEarly.Bang)
      qed
    qed
  }

  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule BRBang)
  ultimately show ?thesis by(auto simp add: strongSimEarly_def)
qed

end


(*  Title:       TLList_CCPO.thy
    Author:      Andreas Lochbihler, ETH Zurich
*)

header {* Ccpo structure for terminated lazy lists *}

theory TLList_CCPO imports TLList begin

context begin interpretation lifting_syntax .
lemma Set_is_empty_parametric [transfer_rule]: "(rel_set A ===> op =) Set.is_empty Set.is_empty"
by(auto simp add: rel_fun_def Set.is_empty_def dest: rel_setD1 rel_setD2)
end

lemma monotone_comp: "\<lbrakk> monotone orda ordb g; monotone ordb ordc f \<rbrakk> \<Longrightarrow> monotone orda ordc (f \<circ> g)"
by(rule monotoneI)(simp add: monotoneD)

lemma mcont_comp: "\<lbrakk> mcont luba orda lubb ordb g; mcont lubb ordb lubc ordc f \<rbrakk> \<Longrightarrow> mcont luba orda lubc ordc (f \<circ> g)"
by(auto simp add: mcont_def intro: cont_comp monotone_comp)

context begin interpretation lifting_syntax .

lemma monotone_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A"
  shows "((A ===> A ===> op =) ===> (B ===> B ===> op =) ===> (A ===> B) ===> op =) monotone monotone"
unfolding monotone_def[abs_def] by transfer_prover

lemma cont_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((rel_set A ===> A) ===> (A ===> A ===> op =) ===> (rel_set B ===> B) ===> (B ===> B ===> op =) ===> (A ===> B) ===> op =) cont cont"
unfolding cont_def[abs_def] Set.is_empty_def[symmetric] by transfer_prover

lemma mcont_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((rel_set A ===> A) ===> (A ===> A ===> op =) ===> (rel_set B ===> B) ===> (B ===> B ===> op =) ===> (A ===> B) ===> op =) mcont mcont"
unfolding mcont_def[abs_def] by transfer_prover

end

lemma (in ccpo) Sup_Un_less:
  assumes chain: "Complete_Partial_Order.chain op \<le> (A \<union> B)"
  and AB: "\<forall>x\<in>A. \<exists>y\<in>B. x \<le> y"
  shows "Sup (A \<union> B) = Sup B"
proof(rule antisym)
  from chain have chain': "Complete_Partial_Order.chain op \<le> B"
    by(blast intro: chain_subset)
  show "Sup (A \<union> B) \<le> Sup B" using chain
  proof(rule ccpo_Sup_least)
    fix x
    assume "x \<in> A \<union> B"
    thus "x \<le> Sup B"
    proof
      assume "x \<in> A"
      then obtain y where "x \<le> y" "y \<in> B" using AB by blast
      note `x \<le> y`
      also from chain' `y \<in> B` have "y \<le> Sup B" by(rule ccpo_Sup_upper)
      finally show ?thesis .
    qed(rule ccpo_Sup_upper[OF chain'])
  qed
  show "Sup B \<le> Sup (A \<union> B)"
    using chain chain' by(blast intro: ccpo_Sup_least ccpo_Sup_upper)
qed

subsection {* The ccpo structure *}

context includes tllist.lifting fixes b :: 'b begin

lift_definition tllist_ord :: "('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist \<Rightarrow> bool"
is "\<lambda>(xs1, b1) (xs2, b2). if lfinite xs1 then b1 = b \<and> lprefix xs1 xs2 \<or> xs1 = xs2 \<and> flat_ord b b1 b2 else xs1 = xs2"
by auto

lift_definition tSup :: "('a, 'b) tllist set \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>A. (lSup (fst ` A), flat_lub b (snd ` (A \<inter> {(xs, _). lfinite xs})))"
proof -
  case (goal1 A1 A2)
  hence "fst ` A1 = fst ` A2" "snd ` (A1 \<inter> {(xs, _). lfinite xs}) = snd ` (A2 \<inter> {(xs, _). lfinite xs})"
    by(auto 4 3 simp add: rel_set_def intro: rev_image_eqI)
  thus ?case by simp
qed

lemma tllist_ord_simps [simp, code]: (* FIXME: does not work with transfer *)
  shows tllist_ord_TNil_TNil: "tllist_ord (TNil b1) (TNil b2) \<longleftrightarrow> flat_ord b b1 b2"
  and tllist_ord_TNil_TCons: "tllist_ord (TNil b1) (TCons y ys) \<longleftrightarrow> b1 = b"
  and tllist_ord_TCons_TNil: "tllist_ord (TCons x xs) (TNil b2) \<longleftrightarrow> False"
  and tllist_ord_TCons_TCons: "tllist_ord (TCons x xs) (TCons y ys) \<longleftrightarrow> x = y \<and> tllist_ord xs ys"
by(auto simp add: tllist_ord.rep_eq flat_ord_def)

lemma tllist_ord_refl [simp]: "tllist_ord xs xs"
by transfer(auto simp add: flat_ord_def)

lemma tllist_ord_antisym: "\<lbrakk> tllist_ord xs ys; tllist_ord ys xs \<rbrakk> \<Longrightarrow> xs = ys"
by transfer(auto simp add: flat_ord_def split: split_if_asm intro: lprefix_antisym)

lemma tllist_ord_trans [trans]: "\<lbrakk> tllist_ord xs ys; tllist_ord ys zs \<rbrakk> \<Longrightarrow> tllist_ord xs zs"
by transfer(auto simp add: flat_ord_def split: split_if_asm intro: lprefix_trans)

lemma chain_tllist_llist_of_tllist:
  assumes "Complete_Partial_Order.chain tllist_ord A"
  shows "Complete_Partial_Order.chain lprefix (llist_of_tllist ` A)"
by(rule chainI)(auto 4 3 simp add: tllist_ord.rep_eq split: split_if_asm dest: chainD[OF assms])

lemma chain_tllist_terminal:
  assumes "Complete_Partial_Order.chain tllist_ord A"
  shows "Complete_Partial_Order.chain (flat_ord b) {terminal xs|xs. xs \<in> A \<and> tfinite xs}"
by(rule chainI)(auto simp add: tllist_ord.rep_eq flat_ord_def dest: chainD[OF assms])

lemma flat_ord_chain_finite:
  assumes "Complete_Partial_Order.chain (flat_ord b) A"
  shows "finite A"
proof -
  from assms have "\<exists>z. \<forall>x\<in>A. x = b \<or> x = z"
    by(clarsimp simp add: chain_def flat_ord_def) metis
  then obtain z where "\<And>x. x \<in> A \<Longrightarrow> x = b \<or> x = z" by blast
  hence "A \<subseteq> {b, z}" by auto
  thus ?thesis by(rule finite_subset) simp
qed

lemma tSup_empty [simp]: "tSup {} = TNil b"
by(transfer)(simp add: flat_lub_def)

lemma is_TNil_tSup [simp]: "is_TNil (tSup A) \<longleftrightarrow> (\<forall>x\<in>A. is_TNil x)"
by transfer(simp add: split_beta)

lemma chain_tllist_ord_tSup:
  assumes chain: "Complete_Partial_Order.chain tllist_ord A"
  and A: "xs \<in> A"
  shows "tllist_ord xs (tSup A)"
proof(cases "tfinite xs")
  case True
  show ?thesis
  proof(cases "llist_of_tllist xs = llist_of_tllist (tSup A)")
    case True
    with `tfinite xs` have "lfinite (lSup (llist_of_tllist ` A))"
      by(simp add: tSup_def image_image)
    hence "terminal (tSup A) = flat_lub b {terminal xs|xs. xs \<in> A \<and> tfinite xs}" (is "_ = flat_lub _ ?A")
      by(simp add: tSup_def terminal_tllist_of_llist image_image)(auto intro: rev_image_eqI intro!: arg_cong[where f="flat_lub b"])
    moreover have "flat_ord b (terminal xs) (flat_lub b ?A)"
      by(rule ccpo.ccpo_Sup_upper[OF Partial_Function.ccpo[OF flat_interpretation]])(blast intro: chain_tllist_terminal[OF chain] A `tfinite xs`)+
    ultimately show ?thesis using True by(simp add: tllist_ord.rep_eq)
  next
    case False
    hence "\<exists>ys\<in>A. \<not> tllist_ord ys xs"
      by(rule contrapos_np)(auto intro!: lprefix_antisym chain_lSup_lprefix chain_lprefix_lSup simp add: tSup_def image_image A chain_tllist_llist_of_tllist[OF chain] tllist_ord.rep_eq split: split_if_asm)
    then obtain ys where "ys \<in> A" "\<not> tllist_ord ys xs" by blast
    with A have "tllist_ord xs ys" "xs \<noteq> ys" by(auto dest: chainD[OF chain])
    with True have "terminal xs = b" by transfer(auto simp add: flat_ord_def)
    with True False show ?thesis
      by(simp add: tllist_ord.rep_eq tSup_def image_image chain_lprefix_lSup chain_tllist_llist_of_tllist chain A)
  qed
next
  case False
  thus ?thesis using assms by(simp add: tllist_ord.rep_eq tSup_def image_image chain_lprefix_lSup chain_tllist_llist_of_tllist not_lfinite_lprefix_conv_eq[THEN iffD1] terminal_tllist_of_llist split: split_if_asm)
qed

lemma chain_tSup_tllist_ord:
  assumes chain: "Complete_Partial_Order.chain tllist_ord A"
  and lub: "\<And>xs'. xs' \<in> A \<Longrightarrow> tllist_ord xs' xs"
  shows "tllist_ord (tSup A) xs"
proof -
  have "\<And>xs'. xs' \<in> llist_of_tllist ` A \<Longrightarrow> lprefix xs' (llist_of_tllist xs)"
    by(auto dest!: lub simp add: tllist_ord.rep_eq split: split_if_asm)
  with chain_tllist_llist_of_tllist[OF chain]
  have prefix: "lprefix (lSup (llist_of_tllist ` A)) (llist_of_tllist xs)"
    by(rule chain_lSup_lprefix)

  show ?thesis
  proof(cases "tfinite (tSup A)")
    case False thus ?thesis using prefix
      by(simp add: tllist_ord.rep_eq tSup_def image_image not_lfinite_lprefix_conv_eq[THEN iffD1])
  next
    case True
    from True have fin: "lfinite (lSup (llist_of_tllist ` A))" by(simp add: tSup_def image_image)
    have eq: "terminal (tSup A) = flat_lub b {terminal xs|xs. xs \<in> A \<and> tfinite xs}" (is "_ = flat_lub _ ?A")
      by(simp add: tSup_def terminal_tllist_of_llist image_image fin)(auto intro: rev_image_eqI intro!: arg_cong[where f="flat_lub b"])

    show ?thesis
    proof(cases "lprefix (llist_of_tllist xs) (lSup (llist_of_tllist ` A))")
      case True
      with prefix have "lSup (llist_of_tllist ` A) = llist_of_tllist xs" by(rule lprefix_antisym)
      moreover have "flat_ord b (flat_lub b ?A) (terminal xs)"
        by(rule ccpo.ccpo_Sup_least[OF Partial_Function.ccpo[OF flat_interpretation]])(auto intro: chain_tllist_terminal[OF chain] dest: lub simp add: tllist_ord.rep_eq flat_ord_def)
      ultimately show ?thesis using eq by(simp add: tllist_ord.rep_eq tSup_def image_image)
    next
      case False
      { fix xs'
        assume "xs' \<in> A"
        with False have "\<not> lprefix (llist_of_tllist xs) (llist_of_tllist xs')"
          by-(erule contrapos_nn, auto 4 4 intro: lprefix_trans chain_lprefix_lSup chain_tllist_llist_of_tllist chain)
        with lub[OF `xs' \<in> A`] have "terminal xs' = b"
          by(auto simp add: tllist_ord.rep_eq split: split_if_asm) }
      with chain_tllist_terminal[OF chain] have "flat_ord b (flat_lub b ?A) b"
        by -(rule ccpo.ccpo_Sup_least[OF Partial_Function.ccpo[OF flat_interpretation]], auto simp add: flat_ord_def)
      hence "flat_lub b ?A = b" by(simp add: flat_ord_def)
      thus ?thesis using True eq prefix
        by(simp add: tSup_def terminal_tllist_of_llist tllist_ord.rep_eq image_image)
    qed
  qed
qed

lemma tllist_ord_ccpo [simp, cont_intro]:
  "class.ccpo tSup tllist_ord (mk_less tllist_ord)"
by unfold_locales(auto simp add: mk_less_def intro: tllist_ord_antisym tllist_ord_trans chain_tllist_ord_tSup chain_tSup_tllist_ord)

lemma tllist_ord_partial_function_definitions: "partial_function_definitions tllist_ord tSup"
by unfold_locales(auto simp add: mk_less_def intro: tllist_ord_antisym tllist_ord_trans chain_tllist_ord_tSup chain_tSup_tllist_ord)

interpretation tllist!: partial_function_definitions "tllist_ord" "tSup"
by(rule tllist_ord_partial_function_definitions)

lemma admissible_mcont_is_TNil [THEN admissible_subst, cont_intro, simp]:
  shows admissible_is_TNil: "ccpo.admissible tSup tllist_ord is_TNil"
by(rule ccpo.admissibleI)(simp)

lemma terminal_tSup:
  "\<forall>xs\<in>Y. is_TNil xs \<Longrightarrow> terminal (tSup Y) = flat_lub b (terminal ` Y)"
including tllist.lifting
apply(transfer)
apply(clarsimp simp add: split_def)
apply(rule arg_cong[where f="flat_lub b"])
apply(auto simp add: split_def)
done

lemma thd_tSup:
  "\<exists>xs \<in> Y. \<not> is_TNil xs
  \<Longrightarrow> thd (tSup Y) = (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs}))"
apply(simp add: tSup_def image_image)
apply(rule arg_cong[where f=The])
apply(auto intro: rev_image_eqI intro!: ext)
done

interpretation lifting_syntax .

lemma ex_TCons_raw_parametric:
  "(rel_set (rel_prod (llist_all2 A) B) ===> op =) (\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs) (\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs)"
by(auto 4 4 simp add: rel_fun_def dest: rel_setD1 rel_setD2 llist_all2_lnullD intro: rev_bexI)

lift_definition ex_TCons :: "('a, 'b) tllist set \<Rightarrow> bool"
is "\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs" parametric ex_TCons_raw_parametric
by(auto dest: rel_setD1 rel_setD2)

lemma ex_TCons_iff: "ex_TCons Y \<longleftrightarrow> (\<exists>xs \<in> Y. \<not> is_TNil xs)"
by transfer auto

lemma retain_TCons_raw_parametric:
  "(rel_set (rel_prod (llist_all2 A) B) ===> rel_set (rel_prod (llist_all2 A) B))
    (\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs}) (\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs})"
by(rule rel_funI rel_setI)+(auto 4 4 dest: llist_all2_lnullD rel_setD2 rel_setD1 intro: rev_bexI)

lift_definition retain_TCons :: "('a, 'b) tllist set \<Rightarrow> ('a, 'b) tllist set"
is "\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs}" parametric retain_TCons_raw_parametric
by(rule rel_setI)(fastforce dest: rel_setD1 rel_setD2)+

lemma retain_TCons_conv: "retain_TCons A = A \<inter> {xs. \<not> is_TNil xs}"
by(auto simp add: retain_TCons_def intro: rev_image_eqI)

lemma ttl_tSup:
  "\<lbrakk> Complete_Partial_Order.chain tllist_ord Y; \<exists>xs \<in> Y. \<not> is_TNil xs \<rbrakk>
  \<Longrightarrow> ttl (tSup Y) = tSup (ttl ` (Y \<inter> {xs. \<not> is_TNil xs}))"
unfolding ex_TCons_iff[symmetric] retain_TCons_conv[symmetric]
proof transfer
  case (goal1 Y)
  then obtain xs b' where xsb: "(xs, b') \<in> Y" "\<not> lnull xs" by blast
  note chain = goal1(1)

  have "flat_lub b (snd ` (Y \<inter> {(xs, _). lfinite xs})) = flat_lub b (insert b (snd ` (Y \<inter> {(xs, _). lfinite xs})))"
    by(auto simp add: flat_lub_def)
  also have "insert b (snd ` (Y \<inter> {(xs, _). lfinite xs})) = insert b (snd ` (apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs}) \<inter> {(xs, _). lfinite xs}))"
    apply(auto intro: rev_image_eqI)
    apply(erule contrapos_np)
    apply(frule chainD[OF chain `(xs, b') \<in> Y`])
    using `\<not> lnull xs` xsb
    by(fastforce split: split_if_asm simp add: lprefix_lnull intro!: rev_image_eqI)
  also have "flat_lub b \<dots> = flat_lub b (snd ` (apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs}) \<inter> {(xs, _). lfinite xs}))"
    by(auto simp add: flat_lub_def)
  also
  have "ltl ` (fst ` Y \<inter> {xs. \<not> lnull xs}) = fst ` apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs})"
    by(auto simp add: image_image)
  ultimately show ?case using goal1 by clarsimp
qed

lemma tSup_TCons: "A \<noteq> {} \<Longrightarrow> tSup (TCons x ` A) = TCons x (tSup A)"
unfolding Set.is_empty_def[symmetric]
apply transfer
unfolding Set.is_empty_def
apply(clarsimp simp add: image_image lSup_LCons[symmetric])
apply(rule arg_cong[where f="flat_lub b"])
apply(auto 4 3 intro: rev_image_eqI)
done

lemma tllist_ord_terminalD:
  "\<lbrakk> tllist_ord xs ys; is_TNil ys \<rbrakk> \<Longrightarrow> flat_ord b (terminal xs) (terminal ys)"
by(cases xs)(auto simp add: is_TNil_def)

lemma tllist_ord_bot [simp]: "tllist_ord (TNil b) xs"
by(cases xs)(simp_all add: flat_ord_def)

lemma tllist_ord_ttlI:
  "tllist_ord xs ys \<Longrightarrow> tllist_ord (ttl xs) (ttl ys)"
by(cases xs ys rule: tllist.exhaust[case_product tllist.exhaust])(simp_all)

lemma not_is_TNil_conv: "\<not> is_TNil xs \<longleftrightarrow> (\<exists>x xs'. xs = TCons x xs')"
by(cases xs) simp_all

subsection {* Continuity of predefined constants *}

lemma mono_tllist_ord_case:
  fixes bot
  assumes mono: "\<And>x. monotone tllist_ord ord (\<lambda>xs. f x xs (TCons x xs))"
  and ord: "class.preorder ord (mk_less ord)"
  and bot: "\<And>x. ord (bot b) x"
  shows "monotone tllist_ord ord (\<lambda>xs. case xs of TNil b \<Rightarrow> bot b | TCons x xs' \<Rightarrow> f x xs' xs)"
proof -
  interpret preorder ord "mk_less ord" by (fact ord)
  show ?thesis by(rule monotoneI)(auto split: tllist.split dest: monotoneD[OF mono] simp add: flat_ord_def bot)
qed

lemma mcont_lprefix_case_aux:
  fixes f bot ord
  defines "g \<equiv> \<lambda>xs. f (thd xs) (ttl xs) (TCons (thd xs) (ttl xs))"
  assumes mcont: "\<And>x. mcont tSup tllist_ord lub ord (\<lambda>xs. f x xs (TCons x xs))"
  and ccpo: "class.ccpo lub ord (mk_less ord)"
  and bot: "\<And>x. ord (bot b) x"
  and cont_bot: "cont (flat_lub b) (flat_ord b) lub ord bot"
  shows "mcont tSup tllist_ord lub ord (\<lambda>xs. case xs of TNil b \<Rightarrow> bot b | TCons x xs' \<Rightarrow> f x xs' xs)"
  (is "mcont _ _ _ _ ?f")
proof(rule mcontI)
  interpret b!: ccpo lub ord "mk_less ord" by(rule ccpo)

  show "cont tSup tllist_ord lub ord ?f"
  proof(rule contI)
    fix Y :: "('a, 'b) tllist set"
    assume chain: "Complete_Partial_Order.chain tllist_ord Y"
      and Y: "Y \<noteq> {}"
    from chain have chain': "Complete_Partial_Order.chain ord (?f ` Y)"
      by(rule chain_imageI)(auto split: tllist.split simp add: flat_ord_def intro!: bot mcont_monoD[OF mcont])

    show "?f (tSup Y) = lub (?f ` Y)"
    proof(cases "is_TNil (tSup Y)")
      case True
      hence "?f ` Y = bot ` terminal ` Y"
        by(auto 4 3 split: tllist.split intro: rev_image_eqI intro!: imageI)
      moreover from True have "tSup Y = TNil (flat_lub b (terminal ` Y))"
        by -(rule tllist.expand, simp_all add: terminal_tSup)
      moreover have "Complete_Partial_Order.chain (flat_ord b) (terminal ` Y)"
        using chain True by(auto intro: chain_imageI tllist_ord_terminalD)
      ultimately show ?thesis using Y by(simp add: contD[OF cont_bot])
    next
      case False
      hence eq: "tSup Y = TCons (thd (tSup Y)) (ttl (tSup Y))" by simp
      have eq':
        "?f ` Y =
         (\<lambda>x. bot (terminal x)) ` (Y \<inter> {xs. is_TNil xs}) \<union>
         (\<lambda>xs. f (thd xs) (ttl xs) xs) ` (Y \<inter> {xs. \<not> is_TNil xs})"
        by(auto 4 3 split: tllist.splits intro: rev_image_eqI)

      from False obtain xs where xs: "xs \<in> Y" "\<not> is_TNil xs" by auto
      { fix ys
        assume "ys \<in> Y" "is_TNil ys"
        hence "terminal ys = b" using xs
          by(cases xs ys rule: tllist.exhaust[case_product tllist.exhaust])(auto dest: chainD[OF chain]) }
      then have lub: "lub (?f ` Y) = lub ((\<lambda>xs. f (thd xs) (ttl xs) xs) ` (Y \<inter> {xs. \<not> is_TNil xs}))"
        using xs chain' unfolding eq'
        by -(erule ccpo.Sup_Un_less[OF ccpo], auto simp add: intro!: bot)
      { fix xs
        assume xs:  "xs \<in> Y \<inter> {xs. \<not> is_TNil xs}"
        hence "(THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) = thd xs"
          by(auto dest: chainD[OF chain] simp add: not_is_TNil_conv intro!: the_equality)
        hence "f (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) (ttl xs) (TCons (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) (ttl xs)) = f (thd xs) (ttl xs) xs"
          using xs by simp }
      moreover have "Complete_Partial_Order.chain tllist_ord (ttl ` (Y \<inter> {xs. \<not> is_TNil xs}))"
        using chain by(rule chain_imageI[OF chain_subset])(auto simp add: tllist_ord_ttlI)
      moreover from False have "Y \<inter> {xs. \<not> is_TNil xs} \<noteq> {}" by auto
      ultimately show ?thesis
        apply(subst (1 2) eq, simp del: b.Sup_image_eq)
        using False
        apply(simp add: thd_tSup ttl_tSup[OF chain] mcont_contD[OF mcont] image_image lub del: b.Sup_image_eq)
        apply(rule arg_cong[where f=lub])
        apply(rule image_cong[OF refl])
        apply simp
        done
    qed
  qed
  from mcont_mono[OF mcont] _ bot
  show "monotone tllist_ord ord ?f"
    by(rule mono_tllist_ord_case)(unfold_locales)
qed

lemma cont_TNil [simp, cont_intro]: "cont (flat_lub b) (flat_ord b) tSup tllist_ord TNil"
apply(rule contI)
apply transfer
apply(simp add: image_image image_constant_conv)
apply(rule arg_cong[where f="flat_lub b"])
apply(auto intro: rev_image_eqI)
done

lemma monotone_TCons: "monotone tllist_ord tllist_ord (TCons x)"
by(rule monotoneI) simp

lemmas mono2mono_TCons[cont_intro] = monotone_TCons[THEN tllist.mono2mono]

lemma mcont_TCons: "mcont tSup tllist_ord tSup tllist_ord (TCons x)"
apply(rule mcontI)
apply(rule monotone_TCons)
apply(rule contI)
apply(simp add: tSup_TCons)
done

lemmas mcont2mcont_TCons[cont_intro] = mcont_TCons[THEN tllist.mcont2mcont]

lemmas [transfer_rule del] = tllist_ord.transfer tSup.transfer

lifting_update tllist.lifting
lifting_forget tllist.lifting

lemmas [transfer_rule] = tllist_ord.transfer tSup.transfer

lemma mono2mono_tset[THEN lfp.mono2mono, cont_intro]:
  shows smonotone_tset: "monotone tllist_ord op \<subseteq> tset"
including tllist.lifting
by transfer(rule monotone_comp[OF _ monotone_lset], auto intro: monotoneI)

lemma mcont2mcont_tset [THEN lfp.mcont2mcont, cont_intro]:
  shows mcont_tset: "mcont tSup tllist_ord Union op \<subseteq> tset"
including tllist.lifting
apply transfer
apply(rule mcont_comp[OF _ mcont_lset])
unfolding mcont_def by(auto intro: monotoneI contI )

end

context begin interpretation lifting_syntax .

lemma rel_fun_lift:
  "(\<And>x. A (f x) (g x)) \<Longrightarrow> (op = ===> A) f g"
by(simp add: rel_fun_def)

lemma tllist_ord_transfer [transfer_rule]:
  "(op = ===> pcr_tllist op = op = ===> pcr_tllist op = op = ===> op =)
     (\<lambda>b (xs1, b1) (xs2, b2). if lfinite xs1 then b1 = b \<and> lprefix xs1 xs2 \<or> xs1 = xs2 \<and> flat_ord b b1 b2 else xs1 = xs2)
     tllist_ord"
by(rule rel_fun_lift)(rule tllist_ord.transfer)

lemma tSup_transfer [transfer_rule]:
  "(op = ===> rel_set (pcr_tllist op = op =) ===> pcr_tllist op = op =)
     (\<lambda>b A. (lSup (fst ` A), flat_lub b (snd ` (A \<inter> {(xs, _). lfinite xs}))))
     tSup"
by(rule rel_fun_lift)(rule tSup.transfer)

end

lifting_update tllist.lifting
lifting_forget tllist.lifting

interpretation tllist!: partial_function_definitions "tllist_ord b" "tSup b" for b
by(rule tllist_ord_partial_function_definitions)

lemma tllist_case_mono [partial_function_mono, cont_intro]:
  assumes tnil: "\<And>b. monotone orda ordb (\<lambda>f. tnil f b)"
  and tcons: "\<And>x xs. monotone orda ordb (\<lambda>f. tcons f x xs)"
  shows "monotone orda ordb (\<lambda>f. case_tllist (tnil f) (tcons f) xs)"
by(rule monotoneI)(auto split: tllist.split dest: monotoneD[OF tnil] monotoneD[OF tcons])

subsection {* Definition of recursive functions *}

locale tllist_pf = fixes b :: 'b
begin

declaration {* Partial_Function.init "tllist" @{term "tllist.fixp_fun b"}
  @{term "tllist.mono_body b"} @{thm tllist.fixp_rule_uc[where b=b]} @{thm tllist.fixp_induct_uc[where b=b]} NONE *}

abbreviation mono_tllist where "mono_tllist \<equiv> monotone (fun_ord (tllist_ord b)) (tllist_ord b)"

lemma LCons_mono [partial_function_mono, cont_intro]:
  "mono_tllist A \<Longrightarrow> mono_tllist (\<lambda>f. TCons x (A f))"
by(rule monotoneI)(auto dest: monotoneD)

end

lemma mono_tllist_lappendt2 [partial_function_mono]:
  "tllist_pf.mono_tllist b A \<Longrightarrow> tllist_pf.mono_tllist b (\<lambda>f. lappendt xs (A f))"
apply(rule monotoneI)
apply(drule (1) monotoneD)
apply(simp add: tllist_ord.rep_eq split: split_if_asm)
apply(auto simp add: lappend_inf)
done

lemma mono_tllist_tappend2 [partial_function_mono]:
  assumes "\<And>y. tllist_pf.mono_tllist b (C y)"
  shows "tllist_pf.mono_tllist b (\<lambda>f. tappend xs (\<lambda>y. C y f))"
apply(cases "tfinite xs")
 apply(rule monotoneI)
 apply(drule monotoneD[OF assms[where y="terminal xs"]])
 including tllist.lifting
 apply transfer
 apply(fastforce split: split_if_asm)
apply(simp add: tappend_inf)
done

end


theory Option_Monad
  imports Main "HOL-Library.Monad_Syntax"
begin

  definition "assert \<Phi> \<equiv> if \<Phi> then Some () else None"
  lemma assert_simps[simp]:
    "assert True = Some ()"
    "assert False = None"
    "assert \<Phi> = Some x \<longleftrightarrow> \<Phi>"
    "assert \<Phi> = None \<longleftrightarrow> \<not>\<Phi>"
    by (auto simp: assert_def)

  definition "wpo c Q \<equiv> \<exists>x. c=Some x \<and> Q x"

  lemma wpo_simps[simp]:
    "\<not>wpo None Q"
    "wpo (Some x) Q \<longleftrightarrow> Q x"
    "wpo (do {x\<leftarrow>m; f x}) Q \<longleftrightarrow> wpo m (\<lambda>x. wpo (f x) Q)"
    "wpo (assert \<Phi>) Qu \<longleftrightarrow> \<Phi> \<and> Qu ()"
    by (auto simp: wpo_def split: Option.bind_splits)

  lemma wpoI:
    "Q x \<Longrightarrow> wpo (Some x) Q"
    "wpo m (\<lambda>x. wpo (f x) Q) \<Longrightarrow> wpo (do {x\<leftarrow>m; f x}) Q"
    "\<lbrakk>\<Phi>; Qu ()\<rbrakk> \<Longrightarrow> wpo (assert \<Phi>) Qu"
    by auto

  lemma wpo_cons:
    "\<lbrakk>wpo c P; \<And>x. P x \<Longrightarrow> Q x\<rbrakk>\<Longrightarrow> wpo c Q"
    by (auto simp: wpo_def)

end


section \<open>Type Classes for ZFC\<close>

theory ZFC_Typeclasses
  imports ZFC_Cardinals Complex_Main

begin

subsection\<open>The class of embeddable types\<close>

class embeddable =
  assumes ex_inj: "\<exists>V_of :: 'a \<Rightarrow> V. inj V_of"

context countable
begin

subclass embeddable
proof -
  have "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
    for to_nat :: "'a \<Rightarrow> nat"
    using that by (simp add: inj_compose inj_ord_of_nat)
  then show "class.embeddable TYPE('a)"
    by intro_classes (meson local.ex_inj)
qed

end

instance unit :: embeddable ..
instance bool :: embeddable ..
instance nat :: embeddable ..
instance int :: embeddable ..
instance rat :: embeddable ..
instance char :: embeddable ..
instance String.literal :: embeddable ..
instance typerep :: embeddable ..

lemma embeddable_classI:
  fixes f :: "'a \<Rightarrow> V"
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "OFCLASS('a, embeddable_class)"
proof (intro_classes, rule exI)
  show "inj f"
    by (rule injI [OF assms]) assumption
qed

instance V :: embeddable
  by (intro_classes) (meson inj_on_id)

instance prod :: (embeddable,embeddable) embeddable
proof -
  have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)" if "inj V_of1" "inj V_of2"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
    using that by (auto simp: inj_on_def)
  then show "OFCLASS('a \<times> 'b, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

instance sum :: (embeddable,embeddable) embeddable
proof -
  have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))" if "inj V_of1" "inj V_of2"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
    using that by (auto simp: inj_on_def split: sum.split_asm)
  then show "OFCLASS('a + 'b, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

instance option :: (embeddable) embeddable
proof -
  have "inj (case_option 0 (\<lambda>x. ZFC_in_HOL.set{V_of x}))" if "inj V_of"
    for V_of :: "'a \<Rightarrow> V"
    using that by (auto simp: inj_on_def split: option.split_asm)
  then show "OFCLASS('a option, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

primrec V_of_list where
  "V_of_list V_of Nil = 0"
| "V_of_list V_of (x#xs) = \<langle>V_of x, V_of_list V_of xs\<rangle>"

lemma inj_V_of_list:
  assumes "inj V_of"
  shows "inj (V_of_list V_of)"
proof -
  note inj_eq [OF assms, simp]
  have "x = y" if "V_of_list V_of x = V_of_list V_of y" for x y
    using that
  proof (induction x arbitrary: y)
    case Nil
    then show ?case
      by (cases y) auto
  next
    case (Cons a x)
    then show ?case
      by (cases y) auto
  qed
  then show ?thesis
    by (auto simp: inj_on_def)
qed

instance list :: (embeddable) embeddable
proof -
  have "inj (rec_list 0 (\<lambda>x xs r. \<langle>V_of x, r\<rangle>))" (is "inj ?f")
    if V_of: "inj V_of" for V_of :: "'a \<Rightarrow> V"
  proof -
    note inj_eq [OF V_of, simp]
    have "x = y" if "?f x = ?f y" for x y
      using that
    proof (induction x arbitrary: y)
      case Nil
      then show ?case
        by (cases y) auto
    next
      case (Cons a x)
      then show ?case
        by (cases y) auto
    qed
    then show ?thesis
      by (auto simp: inj_on_def)
  qed
  then show "OFCLASS('a list, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

subsection\<open>The class of small types\<close>

class small =
  assumes small: "small (UNIV::'a set)"
begin

subclass embeddable
  by intro_classes (meson local.small small_def)

lemma TC_small [iff]:
  fixes A :: "'a set"
  shows "small A"
  using small smaller_than_small by blast

end

context countable
begin

subclass small
proof -
  have *: "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
    for to_nat :: "'a \<Rightarrow> nat"
    using that by (simp add: inj_compose inj_ord_of_nat)
  then show "class.small TYPE('a)"
    by intro_classes (metis small_image_nat local.ex_inj the_inv_into_onto)
qed

end

lemma lepoll_UNIV_imp_small: "X \<lesssim> (UNIV::'a::small set) \<Longrightarrow> small X"
  by (meson lepoll_iff replacement small smaller_than_small)

lemma lepoll_imp_small:
  fixes A :: "'a::small set"
  assumes "X \<lesssim> A"
  shows "small X"
  by (metis lepoll_UNIV_imp_small UNIV_I assms lepoll_def subsetI)

instance unit :: small ..
instance bool :: small ..
instance nat :: small ..
instance int :: small ..
instance rat :: small ..
instance char :: small ..
instance String.literal :: small ..
instance typerep :: small ..

instance prod :: (small,small) small
proof -
  have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)"
       "range (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>) \<le> elts (VSigma A (\<lambda>x. B))"
    if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
    using that by (auto simp: inj_on_def)
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a \<times> 'b, small_class)"
    by intro_classes (smt (verit) down_raw f_inv_into_f set_eq_subset small_def)
qed

instance sum :: (small,small) small
proof -
  have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))"
       "range (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2)) \<le> elts (A \<Uplus> B)"
    if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
    using that by (force simp: inj_on_def split: sum.split)+
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a + 'b, small_class)"
    by intro_classes (metis down_raw replacement set_eq_subset small_def small_iff)
qed

instance option :: (small) small
proof -
  have "inj (\<lambda>x. case x of None \<Rightarrow> 0 | Some x \<Rightarrow> ZFC_in_HOL.set {V_of x})"
       "range (\<lambda>x. case x of None \<Rightarrow> 0 | Some x \<Rightarrow> ZFC_in_HOL.set {V_of x}) \<le> insert 0 (elts (VPow A))"
    if "inj V_of" "range V_of \<le> elts A"
    for V_of :: "'a \<Rightarrow> V" and A
    using that  by (auto simp: inj_on_def split: option.split_asm)
  with small [where 'a='a]
  show "OFCLASS('a option, small_class)"
    by intro_classes (smt (verit) down order.refl ex_inj small_iff small_image_iff small_insert)
qed

instance list :: (small) small
proof -
  have "small (range (V_of_list V_of))"
    if "inj V_of" "range V_of \<le> elts A"
    for V_of :: "'a \<Rightarrow> V" and A
  proof -
    have "range (V_of_list V_of) \<approx> (UNIV :: 'a list set)"
      using that by (simp add: inj_V_of_list)
    also have "\<dots> \<approx> lists (UNIV :: 'a set)"
      by simp
    also have "\<dots> \<lesssim> (UNIV :: 'a set) \<times> (UNIV :: nat set)"
    proof (cases "finite (range (V_of::'a \<Rightarrow> V))")
      case True
      then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: nat set)"
        using countable_iff_lepoll countable_image_inj_on that(1) uncountable_infinite by blast
      then show ?thesis
        by (blast intro: lepoll_trans [OF _ lepoll_times2])
    next
      case False
      then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: 'a set)"
        using \<open>infinite (range V_of)\<close> eqpoll_imp_lepoll infinite_eqpoll_lists by blast
      then show ?thesis
        using lepoll_times1 lepoll_trans by fastforce
    qed
    finally show ?thesis
      by (simp add: lepoll_imp_small)
  qed
  with small [where 'a='a]
  show "OFCLASS('a list, small_class)"
    by intro_classes (metis inj_V_of_list order.refl small_def small_iff small_iff_range)
qed

instance "fun" :: (small,embeddable) embeddable
proof -
  have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))"
    if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A
  proof -
    have "f u = f' u"
      if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
      for f f' :: "'a \<Rightarrow> 'b" and u
      by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
    then show ?thesis
      by (auto simp: inj_on_def)
  qed
  then show "OFCLASS('a \<Rightarrow> 'b, embeddable_class)"
    by intro_classes (metis embeddable_class.ex_inj small order_refl replacement small_iff)
qed

instance "fun" :: (small,small) small
proof -
  have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))"   (is "inj ?\<phi>")
       "range (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x)))) \<le> elts (VPi A (\<lambda>x. B))"
    if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" and "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
  proof -
    have "f u = f' u"
      if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
      for f f' :: "'a \<Rightarrow> 'b" and u
      by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
    then show "inj ?\<phi>"
      by (auto simp: inj_on_def)
    show "range ?\<phi> \<le> elts (VPi A (\<lambda>x. B))"
      using that by (simp add: VPi_I subset_eq)
  qed
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a \<Rightarrow> 'b, small_class)"
    by intro_classes (smt (verit, best) down_raw order_refl imageE small_def)
qed

instance set :: (small) small
proof -
  have 1: "inj (\<lambda>x. ZFC_in_HOL.set (V_of ` x))"
    if "inj V_of" for V_of :: "'a \<Rightarrow> V"
    by (simp add: inj_on_def inj_image_eq_iff [OF that])
  have 2: "range (\<lambda>x. ZFC_in_HOL.set (V_of ` x)) \<le> elts (VPow A)"
    if "range V_of \<le> elts A" for V_of :: "'a \<Rightarrow> V" and A
    using that by (auto simp: inj_on_def image_subset_iff)
  from small [where 'a='a]
  show "OFCLASS('a set, small_class)"
    by intro_classes (metis 1 2 down_raw imageE small_def order_refl)
qed

instance real :: small
proof -
  have "small (range (Rep_real))"
    by simp
  then show "OFCLASS(real, small_class)"
    by intro_classes (metis Rep_real_inverse image_inv_f_f inj_on_def replacement)
qed

instance complex :: small
proof -
  have "\<And>c. c \<in> range (\<lambda>(x,y). Complex x y)"
    by (metis case_prod_conv complex.exhaust_sel rangeI)
  then show "OFCLASS(complex, small_class)"
    by intro_classes (meson TC_small replacement smaller_than_small subset_eq)
qed

end


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

lemma nilBisim[dest]:
  fixes a :: name
  and   b :: name
  and   x :: name
  and   P :: pi

  shows "\<tau>.(P) \<sim> \<zero> \<Longrightarrow> False"
  and   "a<x>.P \<sim> \<zero> \<Longrightarrow> False"
  and   "a{b}.P \<sim> \<zero> \<Longrightarrow> False"
  and   "\<zero> \<sim> \<tau>.(P) \<Longrightarrow> False"
  and   "\<zero> \<sim> a<x>.P \<Longrightarrow> False"
  and   "\<zero> \<sim> a{b}.P \<Longrightarrow> False"
by(auto dest: bisimE symmetric)

(******** Structural Congruence **********)

lemma matchId:
  fixes a :: name
  and   P :: pi

  shows "[a\<frown>a]P \<sim> P"
proof -
  let ?X = "{([a\<frown>a]P, P), (P, [a\<frown>a]P)}"
  have "([a\<frown>a]P, P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: matchIdLeft matchIdRight reflexive)
qed

lemma matchNil:
  fixes a :: name
  and   b :: name

  assumes "a \<noteq> b"

  shows "[a\<frown>b]P \<sim> \<zero>"
proof -
  let ?X = "{([a\<frown>b]P, \<zero>), (\<zero>, [a\<frown>b]P)}"
  have "([a\<frown>b]P, \<zero>) \<in> ?X" by simp
  thus ?thesis using \<open>a \<noteq> b\<close>
    by(coinduct rule: bisimCoinduct) (auto intro: matchNilLeft nilSimRight reflexive)
qed

lemma mismatchId:
  fixes a :: name
  and   b :: name
  and   P :: pi

  assumes "a \<noteq> b"

  shows "[a\<noteq>b]P \<sim> P"
proof -
  let ?X = "{([a\<noteq>b]P, P), (P, [a\<noteq>b]P)}"
  have "([a\<noteq>b]P, P) \<in> ?X" by simp
  thus ?thesis using \<open>a \<noteq> b\<close>
    by(coinduct rule: bisimCoinduct) (auto intro: mismatchIdLeft mismatchIdRight reflexive)
qed

lemma nilRes:
  fixes x :: name

  shows "<\<nu>x>\<zero> \<sim> \<zero>"
proof -
  let ?X = "{(<\<nu>x>\<zero>, \<zero>), (\<zero>, <\<nu>x>\<zero>)}"
  have "(<\<nu>x>\<zero>, \<zero>) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: nilSimRight resNilRight)
qed

lemma resComm:
  fixes x :: name
  and   y :: name
  and   P :: pi

  shows "<\<nu>x><\<nu>y>P \<sim> <\<nu>y><\<nu>x>P"
proof -
  let ?X = "{(<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) | x y P. True}"
  have "(<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim xyP yxP)
    {
      fix x y P
      have "\<And>x y P. (<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) \<in> ?X \<union> bisim" by auto
      moreover have "Id \<subseteq> ?X \<union> bisim" by(auto intro: reflexive)
      moreover have "eqvt ?X" by(force simp add: eqvt_def)
      hence "eqvt(?X \<union> bisim)" by auto
      ultimately have "<\<nu>x><\<nu>y>P \<leadsto>[(?X \<union> bisim)] <\<nu>y><\<nu>x>P" by(rule resComm)
    }
    with \<open>(xyP, yxP) \<in> ?X\<close> show ?case by auto
  next
    case(cSym xyP yxP)
    thus ?case by auto
  qed
qed

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<sim> Q \<oplus> P"
proof -
  let ?X = "{(P \<oplus> Q, Q \<oplus> P), (Q \<oplus> P, P \<oplus> Q)}"
  have "(P \<oplus> Q, Q \<oplus> P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: reflexive sumSym)
qed

lemma sumIdemp:
  fixes P :: pi

  shows "P \<oplus> P \<sim> P"
proof -
  let ?X = "{(P \<oplus> P, P), (P, P \<oplus> P)}"
  have "(P \<oplus> P, P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: reflexive sumIdempLeft sumIdempRight)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<sim> P"
proof -
  let ?X = "{(P \<parallel> \<zero>, P) | P. True} \<union> {(P, P \<parallel> \<zero>) | P . True}"
  have "(P \<parallel> \<zero>, P) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct, auto intro: parZeroRight parZeroLeft)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<sim> Q \<parallel> P"
proof -
  let ?X = "{(resChain lst (P \<parallel> Q), resChain lst (Q \<parallel> P)) | lst P Q. True}"
  have "(P \<parallel> Q, Q \<parallel> P) \<in> ?X" by(blast intro: resChain.base[THEN sym])
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim PQ QP)
    {
      fix lst P Q
      have "\<And>P Q. (P \<parallel> Q, Q \<parallel> P) \<in> ?X \<union> bisim" by(blast intro: resChain.base[THEN sym])
      moreover have Res: "\<And>x P Q. (P, Q) \<in> ?X \<union> bisim \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X \<union> bisim"
        by(auto intro: resPres resChain.step[THEN sym])
      ultimately have "P \<parallel> Q \<leadsto>[(?X \<union> bisim)] Q \<parallel> P" by(rule parSym)
      moreover have "eqvt ?X" by(force simp add: eqvt_def)
      hence "eqvt(?X \<union> bisim)" by auto
      ultimately have "resChain lst (P \<parallel> Q) \<leadsto>[(?X \<union> bisim)] resChain lst (Q \<parallel> P)" using Res
        by(rule resChainI)
    }
    with \<open>(PQ, QP) \<in> ?X\<close> show ?case by auto
  next
    case(cSym PQ QP)
    thus ?case by auto
  qed
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<sim> P \<parallel> <\<nu>x>Q"
proof -
  let ?X = "{(resChain lst (<\<nu>x>(P \<parallel> Q)), resChain lst (P \<parallel> <\<nu>x>Q)) | lst x P Q. x \<sharp> P} \<union>
            {(resChain lst (P \<parallel> <\<nu>x>Q), resChain lst (<\<nu>x>(P \<parallel> Q))) | lst x P Q. x \<sharp> P}"
  let ?Y = "bisim O (?X \<union> bisim) O bisim"

  have Res: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by(blast intro: resChain.step[THEN sym])

  from \<open>x \<sharp> P\<close> have "(<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?X" by(blast intro: resChain.base[THEN sym])
  moreover have EqvtX: "eqvt ?X" by(fastforce simp add: eqvt_def name_fresh_left name_rev_per)
  ultimately show ?thesis
  proof(coinduct rule: bisimTransitiveCoinduct)
    case(cSim P Q)
    {
      fix P Q lst x
      assume "(x::name) \<sharp> (P::pi)"
      moreover have "Id \<subseteq> ?Y" by(blast intro: reflexive)
      moreover from \<open>eqvt ?X\<close> bisimEqvt have "eqvt ?Y" by blast
      moreover have "\<And>P Q x. x \<sharp> P \<Longrightarrow> (<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.base[THEN sym] reflexive)
      moreover {
        fix P Q x y
        have "<\<nu>x><\<nu>y>(P \<parallel> Q) \<sim> <\<nu>y><\<nu>x>(P \<parallel> Q)" by(rule resComm)
        moreover assume "x \<sharp> P"
        hence "(<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?X" by(fastforce intro: resChain.base[THEN sym])
        hence "(<\<nu>y><\<nu>x>(P \<parallel> Q), <\<nu>y>(P \<parallel> <\<nu>x>Q)) \<in> ?X" by(rule Res)
        ultimately have  "(<\<nu>x><\<nu>y>(P \<parallel> Q), <\<nu>y>(P \<parallel> <\<nu>x>Q)) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "<\<nu>x>(P \<parallel> Q) \<leadsto>[?Y] (P \<parallel> <\<nu>x>Q)" by(rule scopeExtParLeft)
      moreover note \<open>eqvt ?Y\<close>
      moreover from Res have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.step[THEN sym] dest: resPres)
      ultimately have "resChain lst (<\<nu>x>(P \<parallel> Q)) \<leadsto>[?Y] resChain lst (P \<parallel> <\<nu>x>Q)"
        by(rule resChainI)
    }
    moreover {
      fix P Q lst x
      assume "(x::name) \<sharp> (P::pi)"
      moreover have "Id \<subseteq> ?Y" by(blast intro: reflexive)
      moreover from \<open>eqvt ?X\<close> bisimEqvt have "eqvt ?Y" by blast
      moreover have "\<And>P Q x. x \<sharp> P \<Longrightarrow> (P \<parallel> <\<nu>x>Q, <\<nu>x>(P \<parallel> Q)) \<in> ?Y"
        by(blast intro: resChain.base[THEN sym] reflexive)
      moreover {
        fix P Q x y
        have "<\<nu>y><\<nu>x>(P \<parallel> Q) \<sim> <\<nu>x><\<nu>y>(P \<parallel> Q)" by(rule resComm)
        moreover assume "x \<sharp> P"
        hence "(P \<parallel> <\<nu>x>Q, <\<nu>x>(P \<parallel> Q)) \<in> ?X" by(fastforce intro: resChain.base[THEN sym])
        hence "(<\<nu>y>(P \<parallel> <\<nu>x>Q), <\<nu>y><\<nu>x>(P \<parallel> Q)) \<in> ?X" by(rule Res)
        ultimately have  "(<\<nu>y>(P \<parallel> <\<nu>x>Q), <\<nu>x><\<nu>y>(P \<parallel> Q)) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "(P \<parallel> <\<nu>x>Q) \<leadsto>[?Y] <\<nu>x>(P \<parallel> Q)"
        by(rule scopeExtParRight)
      moreover note \<open>eqvt ?Y\<close>
      moreover from Res have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.step[THEN sym] dest: resPres)
      ultimately have "resChain lst (P \<parallel> <\<nu>x>Q) \<leadsto>[?Y] resChain lst (<\<nu>x>(P \<parallel> Q))"
        by(rule resChainI)
    }
    ultimately show ?case using \<open>(P, Q) \<in> ?X\<close> by auto
  next
    case(cSym P Q)
    thus ?case
      by auto (blast dest: symmetric transitive intro: resChain.base[THEN sym] reflexive)+
  qed
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes xFreshQ: "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<sim> (<\<nu>x>P) \<parallel> Q"
proof -
  have "<\<nu>x>(P \<parallel> Q) \<sim> <\<nu>x>(Q \<parallel> P)"
  proof -
    have "P \<parallel> Q \<sim> Q \<parallel> P" by(rule parSym)
    thus ?thesis by(rule resPres)
  qed
  moreover from xFreshQ have "<\<nu>x>(Q \<parallel> P) \<sim> Q \<parallel> (<\<nu>x>P)" by(rule scopeExtPar)
  moreover have "Q \<parallel> <\<nu>x>P \<sim> (<\<nu>x>P) \<parallel> Q" by(rule parSym)
  ultimately show ?thesis by(blast intro: transitive)
qed

  shows "(P \<parallel> Q) \<parallel> R \<sim> P \<parallel> (Q \<parallel> R)"
proof -
  let ?X = "{(resChain lst ((P \<parallel> Q) \<parallel> R), resChain lst (P \<parallel> (Q \<parallel> R))) | lst P Q R. True}"
  let ?Y = "bisim O (?X \<union> bisim) O bisim"

  have ResX: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X"
    by(blast intro: resChain.step[symmetric])
  hence ResY: "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
    by(blast intro: resChain.step[symmetric] dest: resPres)

  have "((P \<parallel> Q) \<parallel> R, P \<parallel> (Q \<parallel> R)) \<in> ?X" by(blast intro: resChain.base[symmetric])
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def)
  ultimately show ?thesis
  proof(coinduct rule: bisimTransitiveCoinduct)
    case(cSim P Q)
    {
      fix P Q R lst
      have "\<And>P Q R. ((P \<parallel> Q) \<parallel> R, P \<parallel> (Q \<parallel> R)) \<in> ?Y" by(blast intro: reflexive resChain.base[symmetric])
      moreover have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y" by(blast intro: resChain.step[symmetric] resPres)
      moreover {
        fix P Q R x
        have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?X" by(rule_tac ResX) (blast intro: resChain.base[symmetric])
        moreover assume "x \<sharp> P"
        hence "<\<nu>x>(P \<parallel> (Q \<parallel> R)) \<sim> P \<parallel> <\<nu>x>(Q \<parallel> R)" by(rule scopeExtPar)
        ultimately have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), P \<parallel> <\<nu>x>(Q \<parallel> R)) \<in> ?Y" by(blast intro: reflexive)
      }
      moreover {
        fix P Q R x
        have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?X" by(rule_tac ResX) (blast intro: resChain.base[symmetric])
        moreover assume "x \<sharp> R"
        hence "<\<nu>x>(P \<parallel> Q) \<parallel> R \<sim> <\<nu>x>((P \<parallel> Q) \<parallel> R)" by(metis scopeExtPar' symmetric)
        ultimately have "(<\<nu>x>(P \<parallel> Q) \<parallel> R, <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "(P \<parallel> Q) \<parallel> R \<leadsto>[?Y] P \<parallel> (Q \<parallel> R)" by(rule parAssocLeft)
      moreover from \<open>eqvt ?X\<close> bisimEqvt have "eqvt ?Y" by blast
      ultimately have "resChain lst ((P \<parallel> Q) \<parallel> R) \<leadsto>[?Y] resChain lst (P \<parallel> (Q \<parallel> R))" using ResY
        by(rule resChainI)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    {
      fix P Q R lst
      have "P \<parallel> (Q \<parallel> R) \<sim> (R \<parallel> Q) \<parallel> P" by(metis parPres parSym transitive)
      moreover have "((R \<parallel> Q) \<parallel> P, R \<parallel> (Q \<parallel> P)) \<in> ?X" by(blast intro: resChain.base[symmetric])
      moreover have "R \<parallel> (Q \<parallel> P) \<sim> (P \<parallel> Q) \<parallel> R" by(metis parPres parSym transitive)
      ultimately have "(P \<parallel> (Q \<parallel> R), (P \<parallel> Q) \<parallel> R) \<in> ?Y" by blast
      hence "(resChain lst (P \<parallel> (Q \<parallel> R)), resChain lst ((P \<parallel> Q) \<parallel> R)) \<in> ?Y" using ResY
        by(induct lst) auto
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by blast
  qed
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>P \<sim> P"
proof -
  have "<\<nu>x>P \<sim> <\<nu>x>P \<parallel> \<zero>" by(rule parZero[THEN symmetric])

  moreover have "<\<nu>x>P \<parallel> \<zero> \<sim> \<zero> \<parallel> <\<nu>x>P" by(rule parSym)
  moreover have "\<zero> \<parallel> <\<nu>x>P \<sim> <\<nu>x>(\<zero> \<parallel> P)" by(rule scopeExtPar[THEN symmetric]) auto
  moreover have "<\<nu>x>(\<zero> \<parallel> P) \<sim> <\<nu>x>(P \<parallel> \<zero>)" by(rule resPres[OF parSym])
  moreover from \<open>x \<sharp> P\<close> have "<\<nu>x>(P \<parallel> \<zero>) \<sim> P \<parallel> <\<nu>x>\<zero>" by(rule scopeExtPar)
  moreover have  "P \<parallel> <\<nu>x>\<zero> \<sim> <\<nu>x>\<zero> \<parallel> P" by(rule parSym)
  moreover have "<\<nu>x>\<zero> \<parallel> P \<sim> \<zero> \<parallel> P" by(rule parPres[OF nilRes])
  moreover have "\<zero> \<parallel> P \<sim> P \<parallel> \<zero>" by(rule parSym)
  moreover have "P \<parallel> \<zero> \<sim> P" by(rule parZero)
  ultimately show ?thesis by(metis transitive)
qed

lemma sumRes:
  fixes x :: name
  and   P :: pi
  and   Q :: pi

  shows "<\<nu>x>(P \<oplus> Q) \<sim> (<\<nu>x>P) \<oplus> (<\<nu>x>Q)"
proof -
  let ?X = "{(<\<nu>x>(P \<oplus> Q), <\<nu>x>P \<oplus> <\<nu>x>Q) | x P Q. True} \<union>
            {(<\<nu>x>P \<oplus> <\<nu>x>Q, <\<nu>x>(P \<oplus> Q)) | x P Q. True}"
  have "(<\<nu>x>(P \<oplus> Q), <\<nu>x>P \<oplus> <\<nu>x>Q) \<in> ?X" by auto
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def)
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: sumResLeft sumResRight reflexive)+
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<sim> P \<oplus> <\<nu>x>Q"
proof -
  have "<\<nu>x>(P \<oplus> Q) \<sim> <\<nu>x>P \<oplus> <\<nu>x>Q" by(rule sumRes)
  moreover from \<open>x \<sharp> P\<close> have "<\<nu>x>P \<oplus> <\<nu>x>Q \<sim> P \<oplus> <\<nu>x>Q"
    by(rule sumPres[OF scopeFresh])
  ultimately show ?thesis by(rule transitive)
qed

lemma bangSC:
  fixes P :: pi

  shows "!P \<sim> P \<parallel> !P"
proof -
  let ?X = "{(!P, P \<parallel> !P), (P \<parallel> !P, !P)}"
  have "(!P, P \<parallel> !P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: bangLeftSC bangRightSC reflexive)
qed

lemma resNil:
  fixes x :: name
  and   y :: name
  and   P :: pi
  and   b :: name

  shows "<\<nu>x>x<y>.P \<sim> \<zero>"
  and   "<\<nu>x>x{b}.P \<sim> \<zero>"
proof -
  let ?X = "{(<\<nu>x>x<y>.P, \<zero>), (\<zero>, <\<nu>x>x<y>.P)}"
  have "(<\<nu>x>x<y>.P, \<zero>) \<in> ?X" by simp
  thus "<\<nu>x>x<y>.P \<sim> \<zero>"
    by(coinduct rule: bisimCoinduct) (auto simp add: simulation_def)
next
  let ?X = "{(<\<nu>x>x{b}.P, \<zero>), (\<zero>, <\<nu>x>x{b}.P)}"
  have "(<\<nu>x>x{b}.P, \<zero>) \<in> ?X" by simp
  thus "<\<nu>x>x{b}.P \<sim> \<zero>"
    by(coinduct rule: bisimCoinduct) (auto simp add: simulation_def)
qed

lemma resInput:
  fixes x :: name
  and   a :: name
  and   y :: name
  and   P :: pi

  assumes "x \<noteq> a"
  and     "x \<noteq> y"

  shows "<\<nu>x>a<y>.P \<sim> a<y>.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>a<y>.P, a<y>.(<\<nu>x>P)) | x a y P. x \<noteq> a \<and> x \<noteq> y} \<union>
            {(a<y>.(<\<nu>x>P), <\<nu>x>a<y>.P) | x a y P. x \<noteq> a \<and> x \<noteq> y}"
  from assms have "(<\<nu>x>a<y>.P, a<y>.(<\<nu>x>P)) \<in> ?X" by auto
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def pt_bij[OF pt_name_inst, OF at_name_inst])
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resInputLeft reflexive resInputRight)+
qed

lemma resOutput:
  fixes x :: name
  and   a :: name
  and   b :: name
  and   P :: pi

  assumes "x \<noteq> a"
  and     "x \<noteq> b"

  shows "<\<nu>x>a{b}.P \<sim> a{b}.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>a{b}.P, a{b}.(<\<nu>x>P)) | x a b P. x \<noteq> a \<and> x \<noteq> b} \<union>
            {(a{b}.(<\<nu>x>P), <\<nu>x>a{b}.P) | x a b P. x \<noteq> a \<and> x \<noteq> b}"
  from assms have "(<\<nu>x>a{b}.P, a{b}.(<\<nu>x>P)) \<in> ?X" by blast
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def pt_bij[OF pt_name_inst, OF at_name_inst])
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resOutputLeft resOutputRight reflexive)+
qed

lemma resTau:
  fixes x :: name
  and   P :: pi

  shows "<\<nu>x>\<tau>.(P) \<sim> \<tau>.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>\<tau>.(P), \<tau>.(<\<nu>x>P)), (\<tau>.(<\<nu>x>P), <\<nu>x>\<tau>.(P))}"
  have "(<\<nu>x>\<tau>.(P), \<tau>.(<\<nu>x>P)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resTauLeft resTauRight reflexive)+
qed

inductive structCong :: "pi \<Rightarrow> pi \<Rightarrow> bool" ("_ \<equiv>\<^sub>s _" [70, 70] 70)
where
  Refl: "P \<equiv>\<^sub>s P"
| Sym:  "P \<equiv>\<^sub>s Q \<Longrightarrow> Q \<equiv>\<^sub>s P"
| Trans: "\<lbrakk>P \<equiv>\<^sub>s Q; Q \<equiv>\<^sub>s R\<rbrakk> \<Longrightarrow> P \<equiv>\<^sub>s R"

| SumComm: "P \<oplus> Q \<equiv>\<^sub>s Q \<oplus> P"
| SumAssoc: "(P \<oplus> Q) \<oplus> R \<equiv>\<^sub>s P \<oplus> (Q \<oplus> R)"
| SumId: "P \<oplus> \<zero> \<equiv>\<^sub>s P"

| ParComm: "P \<parallel> Q \<equiv>\<^sub>s Q \<parallel> P"
| ParAssoc: "(P \<parallel> Q) \<parallel> R \<equiv>\<^sub>s P \<parallel> (Q \<parallel> R)"
| ParId: "P \<parallel> \<zero> \<equiv>\<^sub>s P"

| MatchId: "[a\<frown>a]P \<equiv>\<^sub>s P"

| ResNil: "<\<nu>x>\<zero> \<equiv>\<^sub>s \<zero>"
| ResComm: "<\<nu>x><\<nu>y>P \<equiv>\<^sub>s <\<nu>y><\<nu>x>P"
| ResSum: "<\<nu>x>(P \<oplus> Q) \<equiv>\<^sub>s <\<nu>x>P \<oplus> <\<nu>x>Q"
| ScopeExtPar: "x \<sharp> P \<Longrightarrow> <\<nu>x>(P \<parallel> Q) \<equiv>\<^sub>s P \<parallel> <\<nu>x>Q"
| InputRes: "\<lbrakk>x \<noteq> a; x \<noteq> y\<rbrakk> \<Longrightarrow> <\<nu>x>a<y>.P \<equiv>\<^sub>s a<y>.(<\<nu>x>P)"
| OutputRes: "\<lbrakk>x \<noteq> a; x \<noteq> b\<rbrakk> \<Longrightarrow> <\<nu>x>a{b}.P \<equiv>\<^sub>s a{b}.(<\<nu>x>P)"
| TauRes: "<\<nu>x>\<tau>.(P) \<equiv>\<^sub>s \<tau>.(<\<nu>x>P)"

| BangUnfold: "!P \<equiv>\<^sub>s P \<parallel> !P"

lemma structCongBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<sim> Q"
using assms
by(induct rule: structCong.induct)
  (auto intro: reflexive symmetric transitive sumSym sumAssoc sumZero parSym parAssoc parZero
               nilRes resComm resInput resOutput resTau sumRes scopeExtPar bangSC matchId mismatchId)

end