(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Step_Sim_Pres
  imports Weak_Early_Step_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>\<guillemotleft>Rel\<guillemotright> \<tau>.(Q)"
proof(induct rule: simCases)
  case(Bound a x Q')
  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 \<alpha> Q')
  have "\<tau>.(Q) \<longmapsto>(\<alpha> \<prec> Q')" by fact
  thus ?case
  proof(induct rule: tauCases', auto simp add: pi.inject residual.inject)
    have "\<tau>.(P) \<Longrightarrow> \<tau> \<prec> P" by(rule Weak_Early_Step_Semantics.Tau)
    with PRelQ show "\<exists>P'. \<tau>.(P) \<Longrightarrow> \<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>\<guillemotleft>Rel\<guillemotright> 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>(a<u>) \<prec> (P[x::=u])"
      by(rule Weak_Early_Step_Semantics.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>\<guillemotleft>Rel\<guillemotright> a{b}.Q"
proof(induct rule: simCases)
  case(Bound c x Q')
  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 \<alpha> Q')
  have "a{b}.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus "\<exists>P'. a{b}.P \<Longrightarrow> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: outputCases', auto simp add: pi.inject residual.inject)
    have "a{b}.P \<Longrightarrow> a[b] \<prec> P" by(rule Weak_Early_Step_Semantics.Output)
    with PRelQ show "\<exists>P'. a{b}.P \<Longrightarrow> a[b] \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

  assumes PSimQ: "P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and     RelRel': "Rel \<subseteq> Rel'"

  shows "[a\<frown>b]P \<leadsto>\<guillemotleft>Rel'\<guillemotright> [a\<frown>b]Q"
proof(induct rule: simCases)
  case(Bound c x Q')
  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 \<alpha> Q')
  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 PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Match)
    with RelRel' PRel 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>\<guillemotleft>Rel\<guillemotright> Q"
  and     RelRel': "Rel \<subseteq> Rel'"

  shows "[a\<noteq>b]P \<leadsto>\<guillemotleft>Rel'\<guillemotright> [a\<noteq>b]Q"
proof(induct rule: simCases)
  case(Bound c x Q')
  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 \<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 \<Longrightarrow>\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans `a \<noteq> b` have "[a\<noteq>b]P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Mismatch)
    with RelRel' PRel show ?case by blast
  qed
qed

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes PSimQ: "P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     C: "Id \<subseteq> Rel'"

  shows "P \<oplus> R \<leadsto>\<guillemotleft>Rel'\<guillemotright> Q \<oplus> R"
proof(induct rule: simCases)
  case(Bound a x Q')
  have "x \<sharp> P \<oplus> R" by fact
  hence xFreshP: "(x::name) \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
  have "Q \<oplus> R \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: sumCases)
    case Sum1
    have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
    with xFreshP PSimQ obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "P \<oplus> R \<Longrightarrow>a<\<nu>x> \<prec> P'" by(rule Weak_Early_Step_Semantics.Sum1)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  next
    case Sum2
    from `R \<longmapsto>a<\<nu>x> \<prec> Q'` have "P \<oplus> R \<longmapsto>a<\<nu>x> \<prec> Q'" by(rule Early_Semantics.Sum2)
    hence "P \<oplus> R \<Longrightarrow>a<\<nu>x> \<prec> Q'" by(rule Weak_Early_Step_Semantics.singleActionChain)
    moreover from C have "(Q', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free \<alpha> Q')
  have "Q \<oplus> R \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: sumCases)
    case Sum1
    have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "P \<oplus> R \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Sum1)
    with RelRel' PRel show ?case by blast
  next
    case Sum2
    from `R \<longmapsto>\<alpha> \<prec> Q'` have "P \<oplus> R \<longmapsto>\<alpha> \<prec> Q'" by(rule Early_Semantics.Sum2)
    hence "P \<oplus> R \<Longrightarrow>\<alpha> \<prec> Q'" by(rule Weak_Early_Step_Semantics.singleActionChain)
    moreover from C have "(Q', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
qed

lemma parPres:
  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>\<guillemotleft>Rel\<guillemotright> 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>\<guillemotleft>Rel'\<guillemotright> Q \<parallel> R"
proof -
  show ?thesis
  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> R \<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'" 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' have "(P' \<parallel> R, Q' \<parallel> R) \<in> Rel'" by(rule Par)
      ultimately show ?case by blast
    next
      case(cPar2 R')
      from `R \<longmapsto> a<\<nu>x> \<prec> R'` `x \<sharp> P` have "P \<parallel> R \<longmapsto>a<\<nu>x> \<prec> (P \<parallel> R')"
        by(rule Early_Semantics.Par2B)
      hence "P \<parallel> R \<Longrightarrow> a<\<nu>x> \<prec> (P \<parallel> R')" by(rule Weak_Early_Step_Semantics.singleActionChain)
      moreover from PRelQ have "(P \<parallel> R', Q \<parallel>  R') \<in> Rel'" by(rule Par)
      ultimately show ?case by blast
    qed
  next
    case(Free \<alpha> QR')
    have "Q \<parallel> R \<longmapsto> \<alpha> \<prec> QR'" 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> \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans have Trans: "P \<parallel> R \<Longrightarrow> \<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Step_Semantics.Par1F)
      moreover from PRel have "(P' \<parallel> R, Q' \<parallel> R) \<in> Rel'" by(blast intro: Par)
      ultimately show ?case by blast
    next
      case(cPar2 R')
      from `R \<longmapsto>\<alpha> \<prec> R'` have "P \<parallel> R \<longmapsto>\<alpha> \<prec> (P \<parallel> R')"
        by(rule Early_Semantics.Par2F)
      hence "P \<parallel> R \<Longrightarrow>\<alpha> \<prec> (P \<parallel> R')" by(rule Weak_Early_Step_Semantics.singleActionChain)
      moreover from PRelQ have "(P \<parallel> R', Q \<parallel>  R') \<in> Rel'" by(rule Par)
      ultimately show ?case by blast
    next
      case(cComm1 Q' R' a b)
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" and RTrans: "R \<longmapsto> a[b] \<prec> R'" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from RTrans have "R \<Longrightarrow>a[b] \<prec> R'" by(rule Weak_Early_Step_Semantics.singleActionChain)
      with PTrans have "P \<parallel> R \<Longrightarrow> \<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm1)
      moreover from P'RelQ' have "(P' \<parallel> R', Q' \<parallel> R') \<in> Rel'" by(rule Par)
      ultimately show ?case by blast
    next
      case(cComm2 Q' R' a b)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" and RTrans: "R \<longmapsto>a<b> \<prec> R'" by fact+

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

      from RTrans have "R \<Longrightarrow>a<b> \<prec> R'" by(rule Weak_Early_Step_Semantics.singleActionChain)
      with PTrans have "P \<parallel> R \<Longrightarrow> \<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm2)
      moreover from P'RelQ' have "(P' \<parallel> R', Q' \<parallel> R') \<in> Rel'" by(rule Par)
      ultimately show ?case by blast
    next
      case(cClose1 Q' R' a x)
      have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" 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(blast dest: simE)

      from RTrans have "R \<Longrightarrow>a<\<nu>x> \<prec> R'" by(rule Weak_Early_Step_Semantics.singleActionChain)
      with PTrans have Trans: "P \<parallel> R \<Longrightarrow> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')" using `x \<sharp> P`
        by(rule Weak_Early_Step_Semantics.Close1)
      moreover from P'RelQ' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> R')) \<in> Rel'"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    next
      case(cClose2 Q' R' a x)
      have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and RTrans: "R \<longmapsto>a<x> \<prec> R'" 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 RTrans have "R \<Longrightarrow>a<x> \<prec> R'" by(rule Weak_Early_Step_Semantics.singleActionChain)
      with PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')" using `x \<sharp> R`
        by(rule Weak_Early_Step_Semantics.Close2)
      moreover from P'RelQ' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> R')) \<in> Rel'"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    qed
  qed
qed

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

  shows "<\<nu>x>P \<leadsto>\<guillemotleft>Rel'\<guillemotright> <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[of _ "(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>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(rule Weak_Early_Step_Semantics.Open)
      hence "<\<nu>x>P \<Longrightarrow>a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')" using `y \<sharp> P` `y \<noteq> x`
        by(force simp add: weakTransitionAlpha 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 C1)
      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> \<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>\<guillemotleft>Rel\<guillemotright> ([(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: Weak_Early_Step_Semantics.ResF C1 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 x. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>x>R, <\<nu>x>S) \<in> Rel"
  and     PRelQ:   "P \<leadsto>\<guillemotleft>Rel\<guillemotright> Q"

  shows "(resChain lst) P \<leadsto>\<guillemotleft>Rel\<guillemotright> (resChain lst) Q"
proof -
  show ?thesis
  proof(induct lst) (* Base case *)
    from PRelQ show "resChain [] P \<leadsto>\<guillemotleft>Rel\<guillemotright> resChain [] Q" by simp
  next (* Inductive step *)
    fix a lst
    assume IH: "(resChain lst P) \<leadsto>\<guillemotleft>Rel\<guillemotright> (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>\<guillemotleft>Rel\<guillemotright> <\<nu>a>(resChain lst Q)" using eqvtRel
      by(rule_tac resPres)

    thus "resChain (a # lst) P \<leadsto>\<guillemotleft>Rel\<guillemotright> resChain (a # lst) Q"
      by simp
  qed
qed

  shows "!P \<leadsto>\<guillemotleft>bangRel Rel'\<guillemotright> !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> bangRel Rel')) \<and>
                     (\<forall>\<alpha> Q'. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<alpha> \<prec> P' \<and> (P', Q') \<in> bangRel Rel'))"
  from eqvtRel have EqvtBangRel: "eqvt(bangRel Rel')" by(rule eqvtBangRel)
  from C1 have BRelRel': "\<And>P Q. (P, Q) \<in> bangRel Rel \<Longrightarrow> (P, Q) \<in> bangRel Rel'"
    by(auto intro: bangRelSubset)

  {
    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>\<guillemotleft>Rel'\<guillemotright> 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 PTrans xFreshR have "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P' \<parallel> R)"
            by(force intro: Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' PBRQ BRelRel' have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel 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> 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 `y \<sharp> Q'` have "Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q')"
            by(simp add: alphaBoundOutput)
          moreover from PRelQ have "P \<leadsto>\<guillemotleft>Rel'\<guillemotright> Q" by(rule Sim)
          ultimately obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>y> \<prec> P'" and P'RelQ': "(P', [(x, y)] \<bullet> Q') \<in> Rel'"
            using `y \<sharp> P`
            by(blast dest: simE)
          from PTrans `y \<sharp> R` have "P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> (P' \<parallel> R)" by(force intro: Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' PBRQ BRelRel' have "(P' \<parallel> R, ([(x, y)] \<bullet> Q') \<parallel> !Q) \<in> bangRel Rel'" by(metis Rel.BRPar)
          with `x \<sharp> Q` `y \<sharp> Q` 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 \<Longrightarrow>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>\<guillemotleft>Rel'\<guillemotright> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'" and RRel: "(P', Q') \<in> Rel'"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Step_Semantics.Par1F)
          moreover from RRel BR BRelRel' have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel'" by(metis Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<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 \<Longrightarrow>a<\<nu>x> \<prec> R'" and R'BRQ': "(R', Q') \<in> (bangRel Rel')"
            by(metis 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'BRQ' C1 have "(P \<parallel> R', Q \<parallel> Q') \<in> (bangRel Rel')" by(blast dest: Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>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 `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'BRQ': "(R', ([(x, y)] \<bullet> Q')) \<in> (bangRel Rel')"
            by(metis 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'BRQ' C1 have "(P \<parallel> R', Q \<parallel> ([(x, y)] \<bullet> Q')) \<in> (bangRel Rel')" by(blast dest: Rel.BRPar)
          with `y \<sharp> Q` `x \<sharp> Q` 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 \<Longrightarrow>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 \<Longrightarrow>\<alpha> \<prec> R' \<and> (R', Q') \<in> bangRel Rel'"
            by(metis simE)
          then obtain R' where RTrans: "R \<Longrightarrow>\<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> bangRel Rel'"
            by blast

          from RTrans have "P \<parallel> R \<Longrightarrow>\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Step_Semantics.Par2F)
          moreover from PRelQ R'RelQ' C1 have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel'" by(blast dest: Rel.BRPar)
          ultimately show " \<exists>P'. P \<parallel> R \<Longrightarrow>\<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>\<guillemotleft>Rel'\<guillemotright> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

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

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.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 \<Longrightarrow>\<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>\<guillemotleft>Rel'\<guillemotright> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

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

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.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 \<Longrightarrow>\<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>\<guillemotleft>Rel'\<guillemotright> Q" by(rule Sim)
          with QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
             by(blast dest: simE)

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

           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> bangRel Rel'"
             by(force intro: Rel.BRPar BRRes)
           ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<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>\<guillemotleft>Rel'\<guillemotright> 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 RBRQ IH have "\<exists>R'.  R \<Longrightarrow>a<x> \<prec> R' \<and> (R', Q'') \<in> bangRel Rel'"
            by auto
          then obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'" and R'RelQ'': "(R', Q'') \<in> bangRel Rel'"
            by blast

          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> bangRel Rel'"
            by(force intro: Rel.BRPar BRRes)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<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: Weak_Early_Step_Semantics.Bang)
      qed
    qed
  }

  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule BRBang)
  ultimately show ?thesis by(auto simp add: weakStepSimulation_def)
qed
(*
lemma bangPres:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PRelQ:      "(P, Q) \<in> Rel"
  and     Sim:        "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto><Rel'> Q"
  and     RelRel':    "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (P, Q) \<in> Rel'"
  and     eqvtRel':   "eqvt Rel'"

  shows "!P \<leadsto><bangRel Rel'> !Q"
proof -
  from eqvtRel' have EqvtBangRel': "eqvt (bangRel Rel')" by(rule eqvtBangRel)
  from RelRel' have BRelRel': "\<And>P Q. (P, Q) \<in> bangRel Rel \<Longrightarrow> (P, Q) \<in> bangRel Rel'"
    by(auto intro: bangRelSubset)
  have "\<And>Rs P. \<lbrakk>!Q \<longmapsto> Rs; (P, !Q) \<in> bangRel Rel\<rbrakk> \<Longrightarrow> weakSimStepAct P Rs P (bangRel Rel')"
  proof -
    fix Rs P
    assume "!Q \<longmapsto> Rs" and "(P, !Q) \<in> bangRel Rel"
    thus "weakSimStepAct P Rs P (bangRel Rel')"
    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 EqvtBangRel' show ?case
        proof(induct rule: simActBoundCases)
          case BoundOutput
          with 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 have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel'"
            by(blast intro: Rel.BRPar BRelRel')
          ultimately show ?case 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(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Step_Semantics.Par1F)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel'"
            by(blast intro: Rel.BRPar BRelRel')
          ultimately show ?case by blast
        qed
      qed
    next
      case(Par2B a x Q' P)
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (a<\<nu>x> \<prec> Q') P (bangRel Rel')" by fact
      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+
        from EqvtBangRel' show ?case
        proof(induct rule: simActBoundCases)
          case BoundOutput
          with IH RBangRelQ have "weakSimStepAct R (a<\<nu>x> \<prec> Q') R (bangRel Rel')" by blast
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                   and R'BangRelQ': "(R', Q') \<in> bangRel Rel'"
            by(simp add: weakSimStepAct_def, blast)

          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> (bangRel Rel')"
            by(blast intro: Rel.BRPar RelRel')
          ultimately show ?case by blast
        qed
      qed
    next
      case(Par2F \<alpha> Q' P)
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (\<alpha> \<prec> Q') P (bangRel Rel')" 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(induct rule: simActFreeCases)
          case Der
          from RBangRelQ have "weakSimStepAct R (\<alpha> \<prec> Q') R (bangRel Rel')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)

          from RTrans have "P \<parallel> R \<Longrightarrow>\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Step_Semantics.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> (bangRel Rel')"
            by(blast intro: Rel.BRPar RelRel')
          ultimately show ?case by blast
        qed
      qed
    next
      case(Comm1 a Q' b Q'' P)
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (a[b] \<prec> Q'') P (bangRel Rel')" 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(induct rule: simActFreeCases)
          case Der
          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(blast dest: simE)

          from RBangRelQ have "weakSimStepAct R (a[b] \<prec> Q'') R (bangRel Rel')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a[b] \<prec> R'"
                           and R'RelQ'': "(R', Q'') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm1)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> (bangRel Rel')"
            by(rule Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(Comm2 a b Q' Q'' P)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (a<b> \<prec> Q'') P (bangRel Rel')" 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(induct rule: simActFreeCases)
          case Der
          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(blast dest: simE)

          from RBangRelQ have "weakSimStepAct R (a<b> \<prec> Q'') R (bangRel Rel')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a<b> \<prec> R'" and R'BangRelQ'': "(R', Q'') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm2)
          moreover from P'RelQ' R'BangRelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> (bangRel Rel')"
            by(rule Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(Close1 a x Q' Q'' P)
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (a<\<nu>x> \<prec> Q'') P (bangRel Rel')" 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(induct rule: simActFreeCases)
          case Der
          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(blast dest: simE)

          from RBangRelQ have "weakSimStepAct R (a<\<nu>x> \<prec> Q'') R (bangRel Rel')" by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                   and R'RelQ'': "(R', Q'') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)

          from PTrans RTrans xFreshP xFreshR 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> (bangRel Rel')"
            by(force intro: Rel.BRPar Rel.BRRes)
          ultimately show ?case by blast
        qed
      qed
    next
      case(Close2 a x Q' Q'' P)
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P (a<x> \<prec> Q'') P (bangRel Rel')" 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(induct rule: simActFreeCases)
          case Der
          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 "weakSimStepAct R (a<x> \<prec> Q'') R (bangRel Rel')" by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'"
                                       and R'RelQ'': "(R', Q'') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)

          from PTrans RTrans xFreshP 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> (bangRel Rel')"
            by(force intro: Rel.BRPar Rel.BRRes)
          ultimately show ?case by blast
        qed
      qed
    next
      case(Bang Rs)
      have IH: "\<And>P. (P, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> weakSimStepAct P Rs P (bangRel Rel')" by fact
      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 "weakSimStepAct (P \<parallel> !P) Rs (P \<parallel> !P) (bangRel Rel')" by(rule IH)
        thus ?case
        proof(simp (no_asm) add: weakSimStepAct_def, auto)
          fix Q' a x
          assume "weakSimStepAct (P \<parallel> !P) (a<\<nu>x> \<prec> Q') (P \<parallel> !P) (bangRel Rel')" and "x \<sharp> P"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>a<\<nu>x> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)
          from PTrans have "!P \<Longrightarrow>a<\<nu>x> \<prec> P'"
            by(force intro: Weak_Early_Step_Semantics.Bang simp add: weakTransition_def)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> (bangRel Rel')" by blast
        next
          fix Q' \<alpha>
          assume "weakSimStepAct (P \<parallel> !P) (\<alpha> \<prec> Q') (P \<parallel> !P) (bangRel Rel')"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<alpha> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> (bangRel Rel')"
            by(simp add: weakSimStepAct_def, blast)
          from PTrans have "!P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Bang)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<alpha> \<prec> P' \<and> (P', Q') \<in> (bangRel Rel')" by blast
        qed
      qed
    qed
  qed
  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
  ultimately show ?thesis by(simp add: simDef)
qed
*)
end


theory SNS_IAS_Eduroam_Spoofing
imports
  "../../Primitive_Matchers/Parser"
begin

section\<open>Example: Eduroam and sns.ias Firewall Script\<close>

definition "everything_but_my_ip = all_but_those_ips [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]"

text\<open>Incoming: everything but my IP\<close>
definition "ipassignment_incoming = [(Iface ''wlan0'', everything_but_my_ip), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_incoming)" by eval

text\<open>Outgoing: only my IP\<close>
definition "ipassignment_outgoing = [(Iface ''wlan0'',  [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_outgoing)" by eval

parse_iptables_save eduroam_fw="eduroam_iptables-save"

thm eduroam_fw_def
thm eduroam_fw_INPUT_default_policy_def

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

value[code] "unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)"

value[code] "collect_ifaces (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

lemma "ipassmt_sanity_defined (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_incoming)" by eval
lemma "ipassmt_sanity_defined (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_outgoing)" by eval

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"
value[code] "debug_ipassmt_ipv4 ipassignment_outgoing (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

text\<open>The ruleset\<close>
lemma "check_simple_fw_preconditions (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))))" by eval
value[code] "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))"
lemma "simple_fw_valid (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval
lemma "simple_fw_valid (to_simple_firewall (lower_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval

text\<open>We do not need to call things such as @{const transform_optimize_dnf_strict} because the
     firewall already is in @{const normalized_nnf_match} (required for @{const no_spoofing_iface})\<close>
lemma "transform_optimize_dnf_strict (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
          unfold_ruleset_INPUT action.Drop (map_of_string_ipv4 eduroam_fw)" by eval

text\<open>The ruleset prevents spoofed incoming packets\<close>
lemma "no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_incoming) (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

text\<open>Ruleset does not prevent that I'm spoofing (which is not necessary anyways since I need root right to spoof, which
      would also enable me to deactivate the firewall). This is only a one-user laptop!\<close>

lemma "transform_optimize_dnf_strict (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
        unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)" by eval

lemma "\<not> no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_outgoing) (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

end


section \<open>Two-Step Observing Quorums Model\<close>

theory Two_Step_Observing
imports "../Observing_Quorums_Opt" "../Two_Steps"
begin

text \<open>To make the coming proofs of concrete algorithms easier, in this model we split
  the @{term olv_round} into two steps.\<close>

subsection \<open>Model definition\<close>
(******************************************************************************)
record tso_state = opt_obsv_state +
  r_votes :: "process \<Rightarrow> val option"

context mono_quorum
begin

definition tso_round0
  :: "round \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> (tso_state \<times> tso_state)set"
  where
  "tso_round0 r S v \<equiv> {(s, s').
    \<comment> \<open>guards\<close>
    r = next_round s
    \<and> two_step r = 0
    \<and> (S \<noteq> {} \<longrightarrow> opt_obs_safe (last_obs s) v)
    \<comment> \<open>actions\<close>
    \<and> s' = s\<lparr>
      next_round := Suc r
      , r_votes := const_map v S
    \<rparr>
  }"

definition obs_guard :: "(process, val)map \<Rightarrow> (process, val)map \<Rightarrow> bool" where
  "obs_guard r_obs r_v \<equiv> \<forall>p.
    (\<forall>v. r_obs p = Some v \<longrightarrow> (\<exists>q. r_v q = Some v))
    \<and> (dom r_v \<in> Quorum \<longrightarrow> (\<exists>q \<in> dom r_v. r_obs p = r_v q))"

definition tso_round1
  :: "round \<Rightarrow> (process, val)map \<Rightarrow> (process, val)map \<Rightarrow> (tso_state \<times> tso_state)set"
  where
  "tso_round1 r r_decisions r_obs \<equiv> {(s, s').
    \<comment> \<open>guards\<close>
    r = next_round s
    \<and> two_step r = 1
    \<and> d_guard r_decisions (r_votes s)
    \<and> obs_guard r_obs (r_votes s)
    \<comment> \<open>actions\<close>
    \<and> s' = s\<lparr>
      next_round := Suc r
      , decisions := decisions s ++ r_decisions
      , last_obs := last_obs s ++ r_obs
    \<rparr>
  }"

definition tso_init where
  "tso_init = { \<lparr> next_round = 0, decisions = Map.empty, last_obs = Map.empty, r_votes = Map.empty \<rparr> }"

definition tso_trans :: "(tso_state \<times> tso_state) set" where
  "tso_trans = (\<Union>r S v. tso_round0 r S v) \<union> (\<Union>r d_f o_f. tso_round1 r d_f o_f) \<union> Id"

definition tso_TS :: "tso_state TS" where
  "tso_TS = \<lparr> init = tso_init, trans = tso_trans \<rparr>"

lemmas tso_TS_defs = tso_TS_def tso_init_def tso_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

definition basic_rel :: "(opt_obsv_state \<times> tso_state)set" where
  "basic_rel = {(sa, sc).
    next_round sa = two_phase (next_round sc)
    \<and> last_obs sc = last_obs sa
    \<and> decisions sc = decisions sa
  }"

definition step0_rel :: "(opt_obsv_state \<times> tso_state)set" where
  "step0_rel = basic_rel"

definition step1_add_rel :: "(opt_obsv_state \<times> tso_state)set" where
  "step1_add_rel = {(sa, sc). \<exists>S v.
    r_votes sc = const_map v S
    \<and> (S \<noteq> {} \<longrightarrow> opt_obs_safe (last_obs sc) v)
  }"

definition step1_rel :: "(opt_obsv_state \<times> tso_state)set" where
  "step1_rel = basic_rel \<inter> step1_add_rel"

definition tso_ref_rel :: "(opt_obsv_state \<times> tso_state)set" where
  "tso_ref_rel \<equiv> {(sa, sc).
    (two_step (next_round sc) = 0 \<longrightarrow> (sa, sc) \<in> step0_rel)
    \<and> (two_step (next_round sc) = 1 \<longrightarrow>
        (sa, sc) \<in> step1_rel
        \<and> (\<exists>sc' r S v. (sc', sc) \<in> tso_round0 r S v \<and> (sa, sc') \<in> step0_rel))
  }"

lemma const_map_equality:
  "(const_map v S = const_map v' S') = (S = S' \<and> (S = {} \<or> v = v'))"
  apply(simp add: const_map_def restrict_map_def)
  by (metis equals0D option.distinct(2) option.inject subsetI subset_antisym)

lemma rhoare_skipI:
  "\<lbrakk> \<And>sa sc sc'. \<lbrakk> (sa, sc) \<in> Pre; (sc, sc') \<in> Tc \<rbrakk> \<Longrightarrow> (sa, sc') \<in> Post \<rbrakk> \<Longrightarrow> {Pre} Id, Tc {>Post}"
  by(auto simp add: PO_rhoare_defs)

lemma tso_round0_refines:
  "{tso_ref_rel} Id, tso_round0 r S v {>tso_ref_rel}"
  apply(rule rhoare_skipI)
  apply(auto simp add: tso_ref_rel_def basic_rel_def step1_rel_def
     step1_add_rel_def  step0_rel_def tso_round0_def const_map_equality conj_disj_distribR
     ex_disj_distrib two_step_phase_Suc)
  done

lemma tso_round1_refines:
  "{tso_ref_rel} \<Union>r S v dec_f Ob. olv_round r S v dec_f Ob, tso_round1 r dec_f o_f {>tso_ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs)
  fix sa sc and sc'
  assume
    R: "(sa, sc) \<in> tso_ref_rel"
    and step1: "(sc, sc') \<in> tso_round1 r dec_f o_f"

  hence step_r: "two_step r = 1" and r_next: "next_round sc = r" by (auto simp add: tso_round1_def)
  then obtain r0 sc0 S0 v0 where
    R0: "(sa, sc0) \<in> step0_rel" and step0: "(sc0, sc) \<in> tso_round0 r0 S0 v0"
    using R
    by(auto simp add: tso_ref_rel_def)

  from step_r r_next R obtain S v where
    v: "r_votes sc = const_map v S"
    and safe: "S \<noteq> {} \<longrightarrow> opt_obs_safe (last_obs sc) v"
    by(auto simp add: tso_ref_rel_def step1_rel_def step1_add_rel_def)

  define sa' where "sa' = sa\<lparr>
      next_round := Suc (next_round sa)
      , decisions := decisions sa ++ dec_f
      , last_obs := last_obs sa ++ const_map v (dom o_f)
    \<rparr>"

  have "S \<in> Quorum \<longrightarrow> dom o_f = UNIV" using step1 v
    by(auto simp add: tso_round1_def obs_guard_def const_map_def)
  moreover have "o_f \<noteq> Map.empty \<longrightarrow> S \<noteq> {}" using step1 v
    by(auto simp add: tso_round1_def obs_guard_def dom_const_map)
  ultimately have
    abs_step:
    "(sa, sa') \<in> olv_round (next_round sa) S v dec_f (dom o_f)" using R safe v step_r r_next step1
    by(clarsimp simp add: tso_ref_rel_def step1_rel_def basic_rel_def sa'_def
      olv_round_def tso_round1_def)

  from v have post_rel: "(sa', sc') \<in> tso_ref_rel" using R step1
    apply(clarsimp simp add: tso_round0_def tso_round1_def
      step0_rel_def basic_rel_def  sa'_def tso_ref_rel_def two_step_phase_Suc o_def
      const_map_is_Some const_map_is_None const_map_equality obs_guard_def
      intro!: arg_cong2[where f=map_add, OF refl])
    apply(auto simp add: const_map_def restrict_map_def intro!: ext)
    done

  from abs_step post_rel show
    "\<exists>sa'. (\<exists>r' S' w dec_f' Ob'. (sa, sa') \<in> olv_round r' S' w dec_f' Ob') \<and> (sa', sc') \<in> tso_ref_rel"
    by blast
qed

lemma TS_Observing_Refines:
  "PO_refines tso_ref_rel olv_TS tso_TS"
  apply(auto simp add: PO_refines_def olv_TS_defs tso_TS_defs
    intro!: tso_round0_refines tso_round1_refines)
  apply(auto simp add: tso_ref_rel_def step0_rel_def basic_rel_def tso_init_def quorum_for_def
    dest: empty_not_quorum)
  done

subsection \<open>Invariants\<close>
(******************************************************************************)

definition TSO_inv1 where
  "TSO_inv1 = {s. two_step (next_round s) = Suc 0 \<longrightarrow>
    (\<exists>v. \<forall>p w. r_votes s p = Some w \<longrightarrow> w = v)}"

lemmas TSO_inv1I = TSO_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas TSO_inv1E [elim] = TSO_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas TSO_inv1D = TSO_inv1_def [THEN setc_def_to_dest, rule_format]

definition TSO_inv2 where
  "TSO_inv2 = {s. two_step (next_round s) = Suc 0 \<longrightarrow>
    (\<forall>p v. (r_votes s p = Some v \<longrightarrow> (\<exists>q. last_obs s q \<in> {None, Some v})))}"

lemmas TSO_inv2I = TSO_inv2_def [THEN setc_def_to_intro, rule_format]
lemmas TSO_inv2E [elim] = TSO_inv2_def [THEN setc_def_to_elim, rule_format]
lemmas TSO_inv2D = TSO_inv2_def [THEN setc_def_to_dest, rule_format]

subsubsection \<open>Proofs of invariants\<close>
(******************************************************************************)

lemma TSO_inv1_inductive:
  "init tso_TS \<subseteq> TSO_inv1"
  "{TSO_inv1} TS.trans tso_TS {> TSO_inv1}"
  by(auto simp add: TSO_inv1_def tso_TS_defs PO_hoare_def
    tso_round0_def tso_round1_def const_map_is_Some two_step_phase_Suc)

lemma TSO_inv1_invariant:
  "reach tso_TS \<subseteq> TSO_inv1"
  by(intro inv_rule_basic TSO_inv1_inductive)

lemma TSO_inv2_inductive:
  "init tso_TS \<subseteq> TSO_inv2"
  "{TSO_inv2} TS.trans tso_TS {> TSO_inv2}"
  by(auto simp add: TSO_inv2_def tso_TS_defs PO_hoare_def
    opt_obs_safe_def tso_round0_def tso_round1_def const_map_is_Some two_step_phase_Suc)

lemma TSO_inv2_invariant:
  "reach tso_TS \<subseteq> TSO_inv2"
  by(intro inv_rule_basic TSO_inv2_inductive)

end

end


theory DataRefinementMore
imports AbstractSepreftime
begin

subsection \<open>Data Refinement\<close>

lemma "{(1,2),(2,4)}``{1,2}={2,4}" by auto

definition conc_fun ("\<Down>") where
  "conc_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT | REST X \<Rightarrow> REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"
                                                                  (* ^- not so sure here *)
definition abs_fun ("\<Up>") where
  "abs_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT
    | REST X \<Rightarrow> if dom X\<subseteq>Domain R then REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R}) else FAILT"
                                                (* ^- not so sure here *)
lemma
  conc_fun_FAIL[simp]: "\<Down>R FAILT = FAILT" and
  conc_fun_RES: "\<Down>R (REST X) = REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"
  unfolding conc_fun_def by (auto split: nrest.split)

(*
lemma conc_fun_RES_sv: "single_valued R \<Longrightarrow>
  \<Down>R (REST X) = REST (\<lambda>c. if c\<in>Dom R then Some (X Sup {X a| a. (c,a)\<in>R})"
*)

lemma nrest_Rel_mono:
  fixes A :: "('a,'b::complete_lattice) nrest"
  shows "A \<le> B \<Longrightarrow> \<Down> R A \<le> \<Down> R B"
  unfolding conc_fun_def
  apply (auto split: nrest.split simp: le_fun_def)
  by (smt complete_lattice_class.Sup_mono mem_Collect_eq)

lemma datarefine_timerefine_commute1:
  assumes "wfR R'"
  shows "\<Down> R (timerefine R' m) \<le> timerefine R' (\<Down> R m)"
  unfolding conc_fun_def timerefine_def
  apply(cases m) apply auto apply(rule le_funI)
  apply(rule Sup_least)
  apply (auto split: option.splits)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper less_eq_option_Some_None mem_Collect_eq)
  apply(rule le_funI)
  apply(rule Sum_any_mono)
  apply(rule mult_right_mono)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper le_funE less_eq_option_Some mem_Collect_eq)
   apply simp
  apply(rule wfR_finite_mult_left )
  using assms by simp

lemma datarefine_timerefine_commute2:
  assumes "wfR R'" and sv: "single_valued R"
  shows "\<Down> R (timerefine R' m) \<ge> timerefine R' (\<Down> R m)"
    unfolding conc_fun_def timerefine_def
    apply(cases m) apply auto  apply(rule le_funI)
    subgoal for x2 x
    proof (cases "\<exists>a. (x, a) \<in> R")
      case True
      from sv have k: "\<And>a. (x, a) \<in> R \<longleftrightarrow> (a = (THE a. (x,a)\<in>R))"
        unfolding single_valued_def apply auto
        subgoal           by (simp add: the_equality)
        subgoal apply(rule theI') using True by auto
        done
      show ?thesis apply(subst k) apply simp
        apply(subst (2) k) by simp
    next
      case False
      then show ?thesis by (auto split: option.splits simp: bot_option_def)
    qed
    done

experiment
begin

definition "m = REST [0\<mapsto>(\<lambda>_.0)(1:=1), 1\<mapsto>(\<lambda>_.0)(0:=1)]"

definition "R = {(0::nat,1::nat),(1,1),(1,0),(1,0)}"

term "(\<lambda>_.0)(x:=y)"

definition "R' = (\<lambda>_.0)(0::nat:=(\<lambda>_.0)(0:=1),1:=(\<lambda>_.0)(0:=1::enat))"

lemma *: "Sum_any (\<lambda>ac. (if ac = Suc 0 then 1 else 0) * R' ac cc)
      = R' 1 cc" sorry
lemma **: "Sum_any (\<lambda>ac. (if ac = 0 then 1 else 0) * R' ac cc)
      = R' 0 cc" sorry

lemma "\<Down> R (timerefine R' m) = SPECT G"
  unfolding conc_fun_def timerefine_def m_def R_def apply auto
  apply(rule ext) unfolding ** * apply auto
  unfolding R'_def  apply auto sorry

lemma " (timerefine R' (\<Down> R m)) = SPECT G2"
  unfolding conc_fun_def timerefine_def m_def R_def apply auto
  apply(rule ext) unfolding ** *
  unfolding R'_def    oops

end

lemma datarefine_timerefine_commute:
  assumes "wfR R'" and sv: "single_valued R"
  shows "\<Down> R (timerefine R' m) = timerefine R' (\<Down> R m)"
  apply(rule antisym)
  subgoal using assms datarefine_timerefine_commute1 by metis
  subgoal using assms datarefine_timerefine_commute2  by metis
  done

lemma pw_conc_nofail[refine_pw_simps]:
  "nofailT (\<Down>R S) = nofailT S"
  by (cases S) (auto simp: conc_fun_RES)

lemma "single_valued A \<Longrightarrow> single_valued B \<Longrightarrow> single_valued (A O B)"
  by (simp add: single_valued_relcomp)

lemma Sup_enatoption_less2: " Sup X = Some \<infinity> \<Longrightarrow> (\<exists>x. Some x \<in> X \<and> enat t < x)"
  using Sup_enat_less2
  by (metis Sup_option_def in_these_eq option.distinct(1) option.sel)

lemma pw_conc_inres[refine_pw_simps]:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> ((\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t) \<comment> \<open> \<and> (\<forall>s' t'. (s,s')\<in>R \<longrightarrow> inresT S' s' t' \<longrightarrow> t' \<le> t )\<close> ))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES  )
      subgoal for t'
        apply(cases t')
         apply auto
        subgoal for n apply(auto dest!: Sup_finite_enat)
          subgoal for a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x="enat n"]) by auto
          done
        subgoal apply(drule Sup_enatoption_less2[where t=t])
          apply auto subgoal for x a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x=x]) by auto
          done
        done
      done
    subgoal
      apply (auto simp: conc_fun_RES)
      by (smt Sup_upper dual_order.trans le_some_optE mem_Collect_eq)
    done
  done

lemma bindT_refine':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'; inresT M x t; inresT M' x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_le_iff refine_pw_simps)
  by blast

experiment
begin

lemma bindT_refine'':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  sorry

thm bindT_refine'' bindT_mono_under_timerefine

lemma
  assumes "wfR tR" and sv: "single_valued R" and sv: "single_valued R'"
  assumes R1: "M \<le> (timerefine tR (\<Down> R'  M'))"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R' \<rbrakk> \<Longrightarrow> f x \<le> (timerefine tR ( \<Down> R  (f' x')))"
  shows "bindT M (\<lambda>x. f x) \<le> (timerefine tR (\<Down> R  (bindT M' (\<lambda>x'. f' x'))))"
  apply(subst datarefine_timerefine_commute[symmetric, OF assms(1,2)])

  apply(rule order.trans)
   defer apply(rule nrest_Rel_mono) apply(subst timerefine_bindT_ge[OF assms(1)]) apply simp
  apply(rule bindT_refine''[where R'=R'])
  apply(rule order.trans[OF R1])
   apply(subst datarefine_timerefine_commute[  OF assms(1,3)]) apply simp
  apply(rule order.trans[OF R2]) apply simp
  apply(subst datarefine_timerefine_commute[  OF assms(1,2)]) apply simp
  done

lemma
  assumes "wfR tR"
  assumes R1: "M \<le> (\<Down> R'(timerefine tR   M'))"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R' \<rbrakk> \<Longrightarrow> f x \<le> ( \<Down> R (timerefine tR  (f' x')))"
  shows "bindT M (\<lambda>x. f x) \<le> (\<Down> R (timerefine tR   (bindT M' (\<lambda>x'. f' x'))))"
  apply(rule order.trans)
   defer apply(rule nrest_Rel_mono) apply(subst timerefine_bindT_ge[OF assms(1)]) apply simp
  apply(rule bindT_refine''[where R'=R'])
  apply(rule R1)
  apply(rule R2) by simp

end

subsubsection \<open>Examples\<close>

definition Rset where "Rset = { (c,a)| c a. set c = a}"

lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
  unfolding conc_fun_def RETURNT_def Rset_def
  apply simp unfolding le_fun_def by auto

lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
  unfolding conc_fun_def RETURNT_def Rset_def
  apply simp unfolding le_fun_def by auto

definition Reven where "Reven = { (c,a)| c a. even c = a}"

lemma "RETURNT 3 \<le> \<Down>Reven (RETURNT False)"
  unfolding conc_fun_def RETURNT_def Reven_def
  apply simp unfolding le_fun_def by auto

lemma "m \<le> \<Down>Id m"
  unfolding conc_fun_def RETURNT_def
  apply (cases m) by auto

lemma "m \<le> \<Down>{} m \<longleftrightarrow> (m=FAILT \<or> m = SPECT bot)"
  unfolding conc_fun_def RETURNT_def
  apply (cases m) apply auto by (metis bot.extremum dual_order.antisym le_funI)

lemma abs_fun_simps[simp]:
  "\<Up>R FAILT = FAILT"
  "dom X\<subseteq>Domain R \<Longrightarrow> \<Up>R (REST X) = REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R})"
  "\<not>(dom X\<subseteq>Domain R) \<Longrightarrow> \<Up>R (REST X) = FAILT"
  unfolding abs_fun_def by (auto  split: nrest.split)

term single_valued

context fixes R assumes SV: "single_valued R" begin

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Sup_sv: "(c, a') \<in> R \<Longrightarrow>  Sup {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma indomD: " M c = Some y \<Longrightarrow> dom M \<subseteq> Domain R \<Longrightarrow> (\<exists>a. (c,a)\<in>R)"
  by auto

lemma conc_abs_swap: "m' \<le> \<Down>R m \<longleftrightarrow> \<Up>R m' \<le> m"
  apply rule
  subgoal (* <-- *)
  unfolding conc_fun_def abs_fun_def using SV
  apply (auto split: nrest.splits)
  subgoal for M M'
    apply (auto simp add: le_fun_def)
    sorry (* by (smt Sup_least antisym le_cases mem_Collect_eq single_valuedD)  *)
  subgoal
    by (smt Collect_cong Domain.DomainI domI domIff empty_Sup empty_def le_map_dom_mono set_rev_mp)
  done

  subgoal (* \<longrightarrow> *)
    unfolding conc_fun_def abs_fun_def using SV
    apply(auto split: nrest.splits if_splits)
    apply (auto simp add: le_fun_def)
    subgoal for M M' c
      apply(cases "M c = None")
       apply auto apply(frule indomD) apply simp
      apply(auto) sorry(*
      apply(simp only: Sup_sv)

      by (me tis (mono_tags, lifting) Sup_le_iff mem_Collect_eq) *)
    done
  done

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Inf_sv: "(c, a') \<in> R \<Longrightarrow>  Inf {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma ac_galois: "galois_connection (\<Up>R) (\<Down>R)"
  apply (unfold_locales)
  by (rule conc_abs_swap)

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Sup_some_svD: "Sup {m a |a. (c, a) \<in> R} = Some t' \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> m a = Some t')"
  using SV by (smt Sup_le_iff dual_order.antisym less_eq_option_Some_None mem_Collect_eq order_refl single_valued_def)

end

lemma pw_abs_nofail[refine_pw_simps]:
  "nofailT (\<Up>R M) \<longleftrightarrow> (nofailT M \<and> (\<forall>x. (\<exists>t. inresT M x t) \<longrightarrow> x\<in>Domain R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_simps abs_fun_def)
  by (metis zero_enat_def zero_le)

(*
lemma pw_abs_inres[refine_pw_simps]:
  "(\<exists>t. inresT (\<Up>R M) a t) \<longleftrightarrow> (nofailT (\<Up>R M) \<longrightarrow> (\<exists>c. (\<exists>t. inresT M c t) \<and> (c,a)\<in>R))"
  apply (cases M)
   apply simp
  apply rule
  subgoal for m
    apply (auto simp: abs_fun_def) (*    *)
    sorry
  subgoal for m
    sorry
  done
*)

lemma pw_conc_nofail[refine_pw_simps]:
  "nofailT (\<Down>R S) = nofailT S"
  by (cases S) (auto simp: conc_fun_RES)

lemma "single_valued A \<Longrightarrow> single_valued B \<Longrightarrow> single_valued (A O B)"
  by (simp add: single_valued_relcomp)

lemma Sup_enatoption_less2: " Sup X = Some \<infinity> \<Longrightarrow> (\<exists>x. Some x \<in> X \<and> enat t < x)"
  using Sup_enat_less2
  by (metis Sup_option_def in_these_eq option.distinct(1) option.sel)

lemma pw_conc_inres[refine_pw_simps]:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> ((\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t) \<comment> \<open> \<and> (\<forall>s' t'. (s,s')\<in>R \<longrightarrow> inresT S' s' t' \<longrightarrow> t' \<le> t ) \<close> ))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES  )
      subgoal for t'
        apply(cases t')
         apply auto
        subgoal for n apply(auto dest!: Sup_finite_enat)
          subgoal for a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x="enat n"]) by auto
          done
        subgoal apply(drule Sup_enatoption_less2[where t=t])
          apply auto subgoal for x a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x=x]) by auto
          done
        done
      done
    subgoal
      apply (auto simp: conc_fun_RES)
      by (smt Sup_upper dual_order.trans le_some_optE mem_Collect_eq)
    done
  done
(*
lemma pw_conc_inres_sv:
  "single_valued R \<Longrightarrow> inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> (\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      by (auto simp: conc_fun_RES dest!: Sup_some_svD)
    subgoal
      by (auto simp: conc_fun_RES Sup_sv )
    done
  done *)

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows
  "single_valued R \<Longrightarrow> Sup {m a| a. (c,a) \<in> R} = None \<longleftrightarrow> c \<notin> Domain R"
  apply rule
  subgoal oops

(*
lemma pw_abs_inre:
  "inresT (\<Up>R M) a t \<longleftrightarrow> (nofailT (\<Up>R M) \<longrightarrow> (\<exists>c. inresT M c t \<and> (c,a)\<in>R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_def)
  done*)

(*
lemma pw_conc_inres:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> (\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    done
  oops *)

lemma sv_the: "single_valued R \<Longrightarrow> (c,a) \<in> R \<Longrightarrow> (THE a. (c, a) \<in> R) = a"
  by (simp add: single_valued_def the_equality)

lemma
  conc_fun_RES_sv:
  assumes SV: "single_valued R"
  shows "\<Down>R (REST X) = REST (\<lambda>c. if c\<in>Domain R then X (THE a. (c,a)\<in>R) else None )"
  unfolding conc_fun_def
  apply(auto split: nrest.split)
  apply(rule ext)
  apply auto
  subgoal using  SV  by (auto simp: Sup_sv sv_the)
  subgoal by (smt Collect_cong Domain.DomainI empty_Sup empty_def)
  done

lemma conc_fun_mono[simp, intro!]:
  shows "mono (\<Down>R)"
  apply rule
  apply (simp add: pw_le_iff)
  by (auto simp: refine_pw_simps)

lemma conc_fun_R_mono:
  assumes "R \<subseteq> R'"
  shows "\<Down>R M \<le> \<Down>R' M"
  using assms
  by (auto simp: pw_le_iff refine_pw_simps)

lemma SupSup_2: "Sup {m a |a. (c, a) \<in> R O S} =  Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R }"
proof -
  have i: "\<And>a. (c,a) \<in> R O S \<longleftrightarrow> (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)" by auto
  have "Sup {m a |a. (c, a) \<in> R O S} = Sup {m a |a. (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)}"
      unfolding i by auto
    also have "...  = Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R}" by auto
    finally show ?thesis .
  qed

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows SupSup: "Sup {Sup {m aa |aa. P a aa c} |a. Q a c} = Sup {m aa |a aa. P a aa c \<and> Q a c}"
  apply(rule antisym)
   subgoal apply(rule Sup_least)
     by (auto intro: Sup_subset_mono)
   subgoal
     unfolding Sup_le_iff apply auto
     by (smt Sup_upper Sup_upper2 mem_Collect_eq)
   done

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows
    SupSup_1: "Sup {Sup {m aa |aa. (a, aa) \<in> S} |a. (c, a) \<in> R} = Sup {m aa |a aa. (a,aa)\<in>S \<and> (c,a)\<in>R}"
  by(rule SupSup)

lemma conc_fun_chain:
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  apply(simp only: conc_fun_RES)
  apply auto apply (rule ext)  unfolding SupSup_1 SupSup_2 by meson

lemma conc_fun_chain_sv:
  assumes SVR: "single_valued R" and SVS: "single_valued S"
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  using SVS apply(simp only: conc_fun_RES_sv)
  using SVR apply(simp only: conc_fun_RES_sv)
  using single_valued_relcomp[OF SVR SVS] apply(simp only: conc_fun_RES_sv)
  apply (auto split: nrest.split)
  apply (rule ext) apply auto
    apply(auto simp add: sv_the)
  apply(subst sv_the) by auto

lemma conc_Id[simp]: "\<Down>Id = id"
  unfolding conc_fun_def [abs_def] by (auto split: nrest.split)

lemma conc_fun_fail_iff[simp]:
  "\<Down>R S = FAILT \<longleftrightarrow> S=FAILT"
  "FAILT = \<Down>R S \<longleftrightarrow> S=FAILT"
  by (auto simp add: pw_eq_iff refine_pw_simps)

lemma conc_trans[trans]:
  assumes A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

lemma conc_trans_sv:
  assumes SV: "single_valued R" "single_valued R'"
    and A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

text \<open>WARNING: The order of the single statements is important here!\<close>
lemma conc_trans_additional[trans]:
  assumes "single_valued R"
  shows
  "\<And>A B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>R  C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>A B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>\<Down>R  C"

  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>    C"
  "\<And>A B C. A\<le>    B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  using assms conc_trans[where R=R and R'=Id]
  by (auto intro: order_trans)

lemma RETURNT_refine:
  assumes "(x,x')\<in>R"
  shows "RETURNT x \<le> \<Down>R (RETURNT x')"
  using assms
  by (auto simp: RETURNT_def conc_fun_RES le_fun_def Sup_upper)

(*
thm bindT_refine'
lemma bindT_refine'2:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'; inresT M x t; inresT M' x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_le_iff refine_pw_simps)
  by blast*)

lemma bindT_refine:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x'. \<lbrakk> (x,x')\<in>R' \<rbrakk>
    \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bind M' (\<lambda>x'. f' x'))"
  apply (rule bindT_refine') using assms by auto

subsection \<open>WHILET refine\<close>

lemma RECT_refine:
  assumes M: "mono2 body"
  assumes R0: "(x,x')\<in>R"
  assumes RS: "\<And>f f' x x'. \<lbrakk> \<And>x x'. (x,x')\<in>R \<Longrightarrow> f x \<le>\<Down>S (f' x'); (x,x')\<in>R \<rbrakk>
    \<Longrightarrow> body f x \<le>\<Down>S (body' f' x')"
  shows "RECT (\<lambda>f x. body f x) x \<le>\<Down>S (RECT (\<lambda>f' x'. body' f' x') x')"
  unfolding RECT_flat_gfp_def
  apply (clarsimp simp add: M)
  apply (rule flatf_fixp_transfer[where
        fp'="flatf_gfp body"
    and B'=body
    and P="\<lambda>x x'. (x',x)\<in>R",
    OF _ _ flatf_ord.fixp_unfold[OF M[THEN trimonoD_flatf_ge]] R0])
  apply simp
  apply (simp add: trimonoD_flatf_ge)
  by (rule RS)

lemma WHILET_refine:
  assumes R0: "(x,x')\<in>R"
  assumes COND_REF: "\<And>x x'. \<lbrakk> (x,x')\<in>R \<rbrakk> \<Longrightarrow> b x = b' x'"
  assumes STEP_REF:
    "\<And>x x'. \<lbrakk> (x,x')\<in>R; b x; b' x' \<rbrakk> \<Longrightarrow> f x \<le> \<Down>R (f' x')"
  shows "whileT b f x \<le> \<Down>R (whileT b' f' x')"
  unfolding whileT_def apply(rule RECT_refine)
    subgoal by(refine_mono)
     apply (fact R0)
    by(auto simp: COND_REF STEP_REF RETURNT_refine intro: bindT_refine[where R'=R])

lemma
  assumes a: "\<And>m n c a. c\<in>Domain R \<Longrightarrow> \<exists>a. SPECT (n c) \<le>  SPECT (m a)"
  shows "(SPECT n) \<le> \<Down> R (SPECT m)"
  using a  apply auto
    unfolding conc_fun_def apply (auto split: nrest.split)
      unfolding le_fun_def apply auto
    proof -
      fix c
      assume "(\<And>c n m. c \<in> Domain R \<Longrightarrow> \<exists>a. \<forall>x. n c x \<le> m a x)"
      oops

lemma SPECT_refines_conc_fun':
  assumes a: "\<And>m c.  M = SPECT m
          \<Longrightarrow> c \<in> dom n \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R M"
proof -
  show ?thesis
    unfolding conc_fun_def apply (auto split: nrest.split)
    subgoal for m unfolding le_fun_def apply auto
    proof -
      fix c
      assume m: "M = SPECT m"
      show "n c \<le> Sup {m a |a. (c, a) \<in> R} "
      proof (cases "c \<in> dom n")
        case True
        with m a obtain a where k: "(c,a)\<in>R" "n c \<le> m a" by blast
        show ?thesis apply(rule  Sup_upper2) using k by auto
      next
        case False
        then show ?thesis
          by (simp add: domIff)
      qed
    qed
    done
qed

lemma SPECT_refines_conc_fun:
  assumes a: "\<And>m c. (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a by auto

lemma SPECT_refines_conc_fun_sv:
  assumes "single_valued R"
    and a: "dom n \<subseteq> Domain R"
    and "\<And>c. c \<in> dom n \<Longrightarrow> n c \<le> (THE a. (c,a)\<in>R)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a
  using indomD[OF assms(1) _ a] domIff
  oops

lemma conc_fun_br: "\<Down> (br \<alpha> I1) (SPECT (emb I2 t))
        = (SPECT (emb (\<lambda>x. I1 x \<and> I2 (\<alpha> x)) t))"
  unfolding conc_fun_RES  apply auto apply(rule ext)
    using Sup_Some by (auto simp: emb'_def br_def bot_option_def Sup_option_def)

end


(*  Title:      HOL/Auth/n_mutualEx_lemma_inv__5_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualEx Protocol Case Study*}

theory n_mutualEx_lemma_inv__5_on_rules imports n_mutualEx_lemma_on_inv__5
begin
section{*All lemmas on causal relation between inv__5*}
lemma lemma_inv__5_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__5  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__5) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*******************************************************************************

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze, Christoph Sprenger
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

chapter\<open>Abstract, and Concrete Parametrized Models\<close>
text\<open>This is the core of our verification -- the abstract and parametrized models that cover a wide
range of protocols.\<close>
section\<open>Network model\<close>
theory Network_Model
  imports
    "infrastructure/Agents"
    "infrastructure/Tools"
    "infrastructure/Take_While"
begin

text\<open>@{term "as"} is already defined as a type synonym for nat.\<close>
type_synonym ifs = nat

text\<open>The authenticated hop information consists of the interface identifiers UpIF, DownIF and an
identifier of the AS to which the hop information belongs. Furthermore, this record is extensible
and can include additional authenticated hop information (aahi).\<close>
record ahi =
  UpIF :: "ifs option"
  DownIF :: "ifs option"
  ASID :: as

type_synonym 'aahi ahis = "'aahi ahi_scheme"

locale network_model = compromised +
  fixes
   auth_seg0 :: "('ainfo \<times> 'aahi ahi_scheme list) set"
   and tgtas :: "as \<Rightarrow> ifs \<Rightarrow> as option"
   and tgtif :: "as \<Rightarrow> ifs \<Rightarrow> ifs option"
begin

subsection \<open>Interface check\<close>
(******************************************************************************)

text \<open>Check if the interfaces of two adjacent hop fields match. If both hops are compromised we also
interpret the link as valid.\<close>
fun if_valid :: "'aahi ahis option \<Rightarrow> 'aahi ahis => 'aahi ahis option \<Rightarrow> bool" where
  "if_valid None hf _ \<comment> \<open>this is the case for the leaf AS\<close>
    = True"
| "if_valid (Some hf1) (hf2) _
    = ((\<exists>downif . DownIF hf2 = Some downif \<and>
        tgtas (ASID hf2) downif = Some (ASID hf1) \<and>
        tgtif (ASID hf2) downif = UpIF hf1)
      \<or> ASID hf1 \<in> bad \<and> ASID hf2 \<in> bad)"

text \<open>makes sure that: the segment is terminated, i.e. the first AS's HF has Eo = None\<close>
fun terminated :: "'aahi ahis list \<Rightarrow> bool" where
  "terminated (hf#xs) \<longleftrightarrow> DownIF hf = None \<or> ASID hf \<in> bad"
| "terminated [] = True" (* we allow this as a special case*)

text \<open>makes sure that: the segment is rooted, i.e. the last HF has UpIF = None\<close>
fun rooted :: "'aahi ahis list \<Rightarrow> bool" where
  "rooted [hf] \<longleftrightarrow> UpIF hf = None \<or> ASID hf \<in> bad"
| "rooted (hf#xs) = rooted xs"
| "rooted [] = True" (* we allow this as a special case*)

abbreviation ifs_valid where
  "ifs_valid pre l nxt \<equiv> TW.holds if_valid pre l nxt"

abbreviation ifs_valid_prefix where
  "ifs_valid_prefix pre l nxt \<equiv> TW.takeW if_valid pre l nxt"

abbreviation ifs_valid_None where
  "ifs_valid_None l \<equiv> ifs_valid None l None"

abbreviation ifs_valid_None_prefix where
  "ifs_valid_None_prefix l \<equiv> ifs_valid_prefix None l None"

lemma strip_ifs_valid_prefix:
  "pfragment ainfo l auth_seg0 \<Longrightarrow> pfragment ainfo (ifs_valid_prefix pre l nxt) auth_seg0"
  by (auto elim: pfragment_prefix' intro: TW.takeW_prefix)

text\<open>Given the AS and an interface identifier of a channel, obtain the AS and interface at the other
end of the same channel.\<close>
abbreviation rev_link :: "as \<Rightarrow> ifs \<Rightarrow> as option \<times> ifs option" where
  "rev_link a1 i1 \<equiv> (tgtas a1 i1, tgtif a1 i1)"

end
end


(*  Author: Tobias Nipkow  *)

section "Completeness of Archive Test"

theory ArchCompProps
imports TameEnumProps ArchCompAux
begin
lemma mgp_pre_iso_test: "minGraphProps g \<Longrightarrow> pre_iso_test(fgraph g)"
apply(simp add:pre_iso_test_def fgraph_def image_def)
apply(rule conjI) apply(blast dest: mgp_vertices_nonempty[symmetric])
apply(rule conjI) apply(blast intro:minGraphProps)
apply(drule minGraphProps11)
apply(simp add:normFaces_def normFace_def verticesFrom_def minVertex_def
               rotate_min_def o_def)
done

corollary iso_test_correct:
 "\<lbrakk> pre_iso_test Fs\<^sub>1; pre_iso_test Fs\<^sub>2 \<rbrakk> \<Longrightarrow>
  iso_test Fs\<^sub>1 Fs\<^sub>2 = (Fs\<^sub>1 \<simeq> Fs\<^sub>2)"
by(simp add:pre_iso_test_def iso_correct inj_on_rotate_min_iff[symmetric]
            distinct_map nof_vertices_def length_remdups_concat)

lemma trie_all_eq_set_of_trie:
  "invar_trie t \<Longrightarrow> all_trie (list_all P) t = (\<forall>v \<in> set_tries t. P v)"
by(simp add: all_trie_eq_ran set_tries_eq_ran)

lemma samet_imp_iso_seteq:
assumes pre1: "\<And>gs g. gsopt = Some gs \<Longrightarrow> g \<in> set_tries gs \<Longrightarrow> pre_iso_test g"
and pre2: "\<And>g. g \<in> set arch \<Longrightarrow> pre_iso_test g"
and inv: "\<And>gs. gsopt = Some gs \<Longrightarrow> invar_trie gs"
and same: "samet gsopt arch"
shows "\<exists>gs. gsopt = Some gs \<and> set_tries gs =\<^sub>\<simeq> set arch"
proof -
  obtain gs where [simp]: "gsopt = Some gs" and test1: "\<And>g. g \<in> set_tries gs \<Longrightarrow>
    \<exists>h \<in> set arch. iso_test g h" and test2: "\<And>g. g \<in> set arch \<Longrightarrow>
    \<exists>h \<in> set_tries gs. iso_test g h"
    using same inv
    by(force simp: samet_def trie_all_eq_set_of_trie invar_of_list all_tries_def
      split:option.splits
      dest: in_set_lookup_of_listD in_set_lookup_set_triesD)
  have "set_tries gs \<subseteq>\<^sub>\<simeq> set arch"
  proof (auto simp:qle_gr.defs)
    fix g assume g: "g \<in> set_tries gs"
    obtain h where h: "h \<in> set arch" and test: "iso_test g h"
      using test1[OF g] by blast
    thus "\<exists>h\<in>set arch. g \<simeq> h"
      using h pre1[OF _ g] pre2[OF h] by (auto simp:iso_test_correct)
  qed
  moreover
  have "set arch \<subseteq>\<^sub>\<simeq> set_tries gs"
  proof (auto simp:qle_gr.defs)
    fix g assume g: "g \<in> set arch"
    obtain h where h: "h \<in> set_tries gs" and test: "iso_test g h"
      using test2[OF g] by blast
    thus "\<exists>h \<in> set_tries gs. g \<simeq> h"
      using h pre1[OF _ h] pre2[OF g] by (auto simp:iso_test_correct)
  qed
  ultimately show ?thesis by (auto simp: qle_gr.seteq_qle_def)
qed

lemma samet_imp_iso_subseteq:
assumes pre1: "\<And>gs g. gsopt = Some gs \<Longrightarrow> g \<in> set_tries gs \<Longrightarrow> pre_iso_test g"
and pre2: "\<And>g. g \<in> set arch \<Longrightarrow> pre_iso_test g"
and inv: "\<And>gs. gsopt = Some gs \<Longrightarrow> invar_trie gs"
and same: "samet gsopt arch"
shows "\<exists>gs. gsopt = Some gs \<and> set_tries gs \<subseteq>\<^sub>\<simeq> set arch"
using qle_gr.seteq_qle_def assms samet_imp_iso_seteq by metis

global_interpretation set_mod_trie:
  set_mod_maps "Trie None []" update_trie lookup_tries invar_trie "(\<simeq>)" iso_test pre_iso_test hash
  defines insert_mod_trie = "set_mod_maps.insert_mod update_trie lookup_tries iso_test hash"
  and worklist_tree_coll_trie = "set_modulo.worklist_tree_coll (Trie None []) insert_mod_trie"
  and worklist_tree_coll_aux_trie = "set_modulo.worklist_tree_coll_aux insert_mod_trie"
  and insert_mod2_trie = "set_modulo.insert_mod2 insert_mod_trie"
  by standard (simp_all add: iso_test_correct)

definition enum_filter_finals ::
  "(graph \<Rightarrow> graph list) \<Rightarrow> graph list
   \<Rightarrow> (nat,nat fgraph) tries option" where
"enum_filter_finals succs = set_mod_trie.worklist_tree_coll succs final fgraph"

definition tameEnumFilter :: "nat \<Rightarrow> (nat,nat fgraph)tries option" where
"tameEnumFilter p = enum_filter_finals (next_tame p) [Seed p]"

lemma TameEnum_tameEnumFilter:
  "tameEnumFilter p = Some t \<Longrightarrow>  set_tries t  =\<^sub>\<simeq> fgraph ` TameEnum\<^bsub>p\<^esub>"
apply(auto simp: tameEnumFilter_def TameEnumP_def enum_filter_finals_def)
apply(drule set_mod_trie.worklist_tree_coll_equiv[OF _ inv_inv_next_tame])
apply (auto simp: set_of_conv inv_Seed mgp_pre_iso_test RTranCl_conv)
done

lemma tameEnumFilter_subseteq_TameEnum:
  "tameEnumFilter p = Some t \<Longrightarrow> set_tries t \<subseteq> fgraph ` TameEnum\<^bsub>p\<^esub>"
by(auto simp add:tameEnumFilter_def TameEnumP_def enum_filter_finals_def
     set_of_conv inv_Seed mgp_pre_iso_test RTranCl_conv
     dest!: set_mod_trie.worklist_tree_coll_subseteq[OF _ inv_inv_next_tame])

lemma inv_tries_tameEnumFilter:
  "tameEnumFilter p = Some t \<Longrightarrow> invar_trie t"
unfolding tameEnumFilter_def enum_filter_finals_def
by(erule set_mod_trie.worklist_tree_coll_inv)

theorem combine_evals_filter:
 "\<forall>g \<in> set arch. pre_iso_test g \<Longrightarrow> samet (tameEnumFilter p) arch
  \<Longrightarrow> fgraph ` TameEnum\<^bsub>p\<^esub> \<subseteq>\<^sub>\<simeq> set arch"
apply(subgoal_tac "\<exists>t. tameEnumFilter p = Some t \<and> set_tries t \<subseteq>\<^sub>\<simeq> set arch")
 apply(metis TameEnum_tameEnumFilter qle_gr.seteq_qle_def qle_gr.subseteq_qle_trans)
apply(fastforce intro!: samet_imp_iso_subseteq
  dest: inv_tries_tameEnumFilter tameEnumFilter_subseteq_TameEnum mgp_TameEnum mgp_pre_iso_test)
done

end