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

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

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

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

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

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

  shows "a<x>.P \<leadsto>[Rel] a<x>.Q"
using Eqvt
proof(induct rule: simCasesCont[where C="(x, a, P, Q)"])
  case(Bound b y Q')
  from `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 \<longmapsto>a<u> \<prec> P[x::=u]" by(rule Input)
    moreover from PRelQ have "(P[x::=u], Q[x::=u]) \<in> Rel" by auto
    ultimately show ?case by blast
  qed
qed

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

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

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

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

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

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

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

  assumes PSimQ: "P \<leadsto>[Rel] Q"
  and     RelRel': "Rel \<subseteq> Rel'"

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

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

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

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

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

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

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

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

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

  shows "P \<parallel> R \<leadsto>[Rel''] Q \<parallel> S"
proof(induct rule: simCases)
  case(Bound a x Q')
  have "x \<sharp> P \<parallel> R" by fact
  hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
  have "Q \<parallel> S \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: parCasesB)
    case(cPar1 Q')
    have "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans:"P \<longmapsto> a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans xFreshR have "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Early_Semantics.Par1B)
    moreover from P'RelQ' RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cPar2 S')
    have "S \<longmapsto> a<\<nu>x> \<prec> S'" by fact
    with RSimT xFreshR obtain R' where RTrans:"R \<longmapsto> a<\<nu>x> \<prec> R'" and R'Rel'T': "(R', S') \<in>  Rel'"
      by(blast dest: elim)

    from RTrans xFreshP have ParTrans: "P \<parallel> R \<longmapsto> a<\<nu>x> \<prec> (P \<parallel> R')" by(rule Early_Semantics.Par2B)
    moreover from PRelQ R'Rel'T' have "(P \<parallel> R', Q \<parallel>  S') \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  qed
next
  case(Free \<alpha> QT')
  have "Q \<parallel> S \<longmapsto> \<alpha> \<prec> QT'" by fact
  thus ?case
  proof(induct rule: parCasesF[of _ _ _ _ _ "(P, R)"])
    case(cPar1 Q')
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<longmapsto> \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: elim)

    from PTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<parallel> R" by(rule Early_Semantics.Par1F)
    moreover from PRel RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cPar2 S')
    have "S \<longmapsto> \<alpha> \<prec> S'" by fact
    with RSimT obtain R' where RTrans: "R \<longmapsto> \<alpha> \<prec> R'" and RRel: "(R', S') \<in> Rel'"
      by(blast dest: elim)

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

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

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

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

    from PTrans RTrans have "P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<parallel> R'" by(rule Early_Semantics.Comm2)
    moreover from PRel R'Rel'T' have "(P' \<parallel> R', Q' \<parallel> S') \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cClose1 Q' S' a x)
    have "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+

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

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

    from PTrans RTrans xFreshP have "P \<parallel> R \<longmapsto> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
      by(rule Early_Semantics.Close1)
    moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  next
    case(cClose2 Q' S' a x)
    have "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+

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

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

    from PTrans RTrans xFreshR have "P \<parallel> R \<longmapsto> \<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
      by(rule Early_Semantics.Close2)
    moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  qed
qed

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

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

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

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

  shows "<\<nu>x>P \<leadsto>[Rel'] <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[where C = "(P, x)"])
    case(Bound a y Q')
    have Trans: "<\<nu>x>Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
    have "y \<sharp> (P, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> (P::pi)" by simp+
    from Trans yineqx show ?case
    proof(induct rule: resCasesB)
      case(Open Q')
      have QTrans: "Q \<longmapsto>(a::name)[x] \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<longmapsto> a[x] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: elim)

      have "<\<nu>x>P \<longmapsto>a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
      proof -
        have aineqx: "a \<noteq> x" by fact
        with PTrans have "<\<nu>x>P \<longmapsto>a<\<nu>x> \<prec> P'" by(rule TransitionsEarly.Open)
        moreover have "a<\<nu>x> \<prec> P' = a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
        proof -
          from PTrans yFreshP have yFreshP': "y \<sharp> P'" by(force intro: freshTransition)
          thus ?thesis by(simp add: alphaBoundOutput name_swap)
        qed
        ultimately show ?thesis by simp
      qed
      moreover from EqvtRel P'RelQ' RelRel' have "([(y, x)] \<bullet> P', [(y, x)] \<bullet> Q') \<in> Rel'"
        by(blast intro: eqvtRelI)
      ultimately show ?case by blast
    next
      case(Res Q')
      have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact

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

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

      ultimately show "\<exists>P'. <\<nu>x>P \<longmapsto> a<\<nu>y> \<prec> P' \<and> (P', (<\<nu>x>Q')) \<in> Rel'" by blast
    qed
  next
    case(Free \<alpha> Q')
    have Trans: "<\<nu>x>Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    have "\<exists>c::name. c \<sharp> (P, Q, Q', \<alpha>)" by(blast intro: name_exists_fresh)
    then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshAlpha: "c \<sharp> \<alpha>" and cFreshQ': "c \<sharp> Q'" and cFreshP: "c \<sharp> P"
      by(force simp add: fresh_prod)
    from cFreshP have "<\<nu>x>P = <\<nu>c>([(x, c)] \<bullet> P)" by(simp add: alphaRes)
    moreover have "\<exists>P'.<\<nu>c>([(x, c)] \<bullet> P) \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
    proof -
      from Trans cFreshQ have "<\<nu>c>([(x, c)] \<bullet> Q) \<longmapsto>\<alpha> \<prec> Q'" by(simp add: alphaRes)
      moreover from EqvtRel PSimQ have "([(x, c)] \<bullet> P) \<leadsto>[Rel] ([(x, c)] \<bullet> Q)"
        by(blast intro: eqvtI)
      ultimately show ?thesis using cFreshAlpha
        apply -
        apply(erule resCasesF)
        apply auto
        by(blast intro: ResF ResSet dest: elim)
    qed

    ultimately show "\<exists>P'.<\<nu>x>P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" by auto
  qed
qed

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

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

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

  shows "!P \<leadsto>[bangRel Rel] !Q"
proof -
  let ?Sim = "\<lambda>P Rs. (\<forall>a x Q'. Rs = a<\<nu>x> \<prec> Q' \<longrightarrow> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<longmapsto>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> bangRel Rel)) \<and>
                     (\<forall>\<alpha> Q'. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> bangRel Rel))"
  from eqvtRel have EqvtBangRel: "eqvt(bangRel Rel)" by(rule eqvtBangRel)

  {
    fix Pa Rs
    assume "!Q \<longmapsto> Rs" and "(Pa, !Q) \<in> bangRel Rel"
    hence "?Sim Pa Rs" using PRelQ
    proof(nominal_induct avoiding: Pa P rule: bangInduct)
      case(Par1B a x Q' Pa P)
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> Pa" by fact+
      thus "?Sim Pa (a<\<nu>x> \<prec> (Q' \<parallel> !Q))"
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" by fact
        have PBRQ: "(R, !Q) \<in> bangRel Rel" by fact
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case
        proof(auto simp add: residual.inject alpha')
          from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)

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

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

          from PTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<parallel> R" by(rule TransitionsEarly.Par1F)
          moreover from RRel BR have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Par2B a x Q' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a<\<nu>x> \<prec> Q')" by simp
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> Pa" by fact+
      thus "?Sim Pa (a<\<nu>x> \<prec> (Q \<parallel> Q'))"
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+

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

          from RTrans have "P \<parallel> R \<longmapsto> \<alpha> \<prec> P \<parallel> R'" by(rule TransitionsEarly.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show " \<exists>P'. P \<parallel> R \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Comm1 a Q' b Q'' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a[b] \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto>a<b> \<prec> Q'" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<longmapsto> a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

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

          from PTrans RTrans have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule TransitionsEarly.Comm1)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', Q' \<parallel> Q'') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Comm2 a b Q' Q'')
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim Pa (a<b> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a[b] \<prec> Q'" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<longmapsto> a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: elim)

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

          from PTrans RTrans have "P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<parallel> R'" by(rule TransitionsEarly.Comm2)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<longmapsto> \<tau> \<prec> P' \<and> (P', Q' \<parallel> Q'') \<in> bangRel Rel" by blast
        qed
      qed
    next
      case(Close1 a x Q' Q'' Pa P)
      hence IH: "\<And>Pa. (Pa, !Q) \<in> bangRel Rel \<longrightarrow> ?Sim Pa (a<\<nu>x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have xFreshQ: "x \<sharp> Q" by fact
      have "(Pa, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      moreover have xFreshPa: "x \<sharp> Pa" by fact
      ultimately show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBRQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto>[Rel] Q" by(rule Sim)
          with QTrans xFreshP obtain P' where PTrans: "P \<longmapsto>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
             by(blast dest: elim)

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

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

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

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

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

end


theory GeneralOntology imports ValueOntology (*Benzm.,Fuenmayor&Lomfeld, 2020*)
begin (**General/Upper Ontology**)

(*kinds of situations*)
consts Animals::"\<sigma>"         (*appropriation of animals in general*)
consts WildAnimals::"\<sigma>"     (*appropriation of wild animals*)
consts DomesticAnimals::"\<sigma>" (*appropriation of domestic animals*)
consts FoxHunting::"\<sigma>"      (*hunting (appropriation) of foxes*)
consts ParrotCapture::"\<sigma>"   (*capture (appropriation) of a parrot*)

(*world knowledge: meaning postulates for kinds of situations*)
axiomatization where
W1: "WildAnimals \<subseteq> Animals" and
W2: "FoxHunting \<subseteq> WildAnimals" and
W3: "DomesticAnimals \<subseteq> Animals" and
W4: "ParrotCapture \<subseteq> DomesticAnimals"

(*(abstract) example legal corpus and implications for value preferences*)
axiomatization where
S2: "\<lfloor>WildAnimals     \<^bold>\<rightarrow> (x\<inverse>\<down>WILL \<^bold>\<prec> x\<down>STAB)\<rfloor>" and        (*specialization*)
S3: "\<lfloor>DomesticAnimals \<^bold>\<rightarrow> (x\<inverse>\<down>STAB \<^bold>\<prec> (x\<down>RELI \<^bold>\<and> x\<down>WILL))\<rfloor>" (*specialization*)

(*explore implicit legal knowledge*)
lemma "\<lfloor>FoxHunting \<^bold>\<rightarrow> (x\<inverse>\<down>WILL \<^bold>\<prec> x\<down>STAB)\<rfloor>" using S2 W2 by blast
lemma "\<lfloor>DomesticAnimals \<^bold>\<rightarrow> (x\<inverse>\<down>WILL \<^bold>\<prec> x\<down>STAB)\<rfloor>" nitpick oops (*Countermodel*)

lemma True nitpick[satisfy] oops (*satisfiable, axioms are consistent*)
end


theory "CoCallGraph-Nominal"
imports CoCallGraph "../Launchbury/Nominal-HOLCF"
begin

instantiation CoCalls :: pt
begin
  lift_definition permute_CoCalls :: "perm \<Rightarrow> CoCalls \<Rightarrow> CoCalls" is "permute"
    by (auto intro!: symI elim: symE simp add: mem_permute_set)
instance
  apply standard
  apply (transfer, simp)+
  done
end

instance CoCalls :: cont_pt
  apply standard
  apply (rule contI2)
  apply (rule monofunI)
  apply transfer
  apply (metis (full_types) True_eqvt subset_eqvt)
  apply (thin_tac "chain _")+
  apply transfer
  apply simp
  done

lemmas lub_eqvt[OF exists_lub, simp, eqvt]

lemma cc_restr_perm:
  fixes G :: CoCalls
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "cc_restr S (p \<bullet> G) = cc_restr S G"
  using assms
  apply -
  apply transfer
  apply (auto simp add: mem_permute_set)
  apply (subst (asm) perm_supp_eq, simp add: supp_minus_perm, metis (full_types) fresh_def fresh_star_def supp_set_elem_finite)+
  apply assumption
  apply (subst perm_supp_eq, simp add: supp_minus_perm, metis (full_types) fresh_def fresh_star_def supp_set_elem_finite)+
  apply assumption
  done

lemma inCC_eqvt[eqvt]: "\<pi> \<bullet> (x--y\<in>G) = (\<pi>\<bullet>x)--(\<pi>\<bullet>y)\<in>(\<pi>\<bullet>G)"
  by transfer auto
lemma cc_restr_eqvt[eqvt]: "\<pi> \<bullet> cc_restr S G = cc_restr (\<pi> \<bullet> S) (\<pi> \<bullet> G)"
  by transfer (perm_simp, rule)
lemma ccProd_eqvt[eqvt]: "\<pi> \<bullet> ccProd S S' = ccProd (\<pi> \<bullet> S) (\<pi> \<bullet>  S')"
  by transfer (perm_simp, rule)
lemma ccSquare_eqvt[eqvt]: "\<pi> \<bullet> ccSquare S = ccSquare (\<pi> \<bullet> S)"
  unfolding ccSquare_def
  by perm_simp rule
lemma ccNeighbors_eqvt[eqvt]: "\<pi> \<bullet> ccNeighbors S G = ccNeighbors (\<pi> \<bullet> S) (\<pi> \<bullet> G)"
  by transfer (perm_simp, rule)

end


section \<open>Infrastructures\<close>
text \<open>The Isabelle Infrastructure framework supports the representation of infrastructures
as graphs with actors and policies attached to nodes. These infrastructures
are the {\it states} of the Kripke structure.
The transition between states is triggered by non-parametrized
actions @{text \<open>get, move, eval, put\<close>} executed by actors.
Actors are given by an abstract type @{text \<open>actor\<close>} and a function
@{text \<open>Actor\<close>} that creates elements of that type from identities
(of type @{text \<open>string\<close>}). Policies are given by pairs of predicates
(conditions) and sets of (enabled) actions.\<close>
subsection \<open>Actors, actions, and data labels\<close>
theory Infrastructure
  imports AT
begin
datatype action = get | move | eval | put

typedecl actor
type_synonym identity = string
consts Actor :: "string \<Rightarrow> actor"
type_synonym policy = "((actor \<Rightarrow> bool) * action set)"

definition ID :: "[actor, string] \<Rightarrow> bool"
  where "ID a s \<equiv> (a = Actor s)"
text \<open>The Decentralised Label Model (DLM) \cite{ml:98} introduced the idea to
label data by owners and readers. We pick up this idea and formalize
a new type to encode the owner and the set of readers as a pair.
The first element is the owner of a data item, the second one is the
set of all actors that may access the data item.
This enables the unique security
labelling of data within the system additionally taking the ownership into
account.\<close>
type_synonym data = nat
type_synonym dlm = "actor * actor set"

subsection \<open>Infrastructure graphs and policies\<close>
text\<open>Actors are contained in an infrastructure graph. An @{text \<open>igraph\<close>} contains
a set of location pairs representing the topology of the infrastructure
as a graph of nodes and a list of actor identities associated to each node
(location) in the graph.
Also an @{text \<open>igraph\<close>} associates actors to a pair of string sets by
a pair-valued function whose first range component is a set describing
the credentials in the possession of an actor and the second component
is a set defining the roles the actor can take on. More importantly in this
context, an  @{text \<open>igraph\<close>} assigns locations to a pair of a string that defines
the state of the component and an element of type @{text \<open>(dlm * data) set\<close>}. This
set of labelled data may represent a condition on that data.
Corresponding projection functions for each of these components of an
@{text \<open>igraph\<close>} are provided; they are named @{text \<open>gra\<close>} for the actual set of pairs of
locations, @{text \<open>agra\<close>} for the actor map, @{text \<open>cgra\<close>} for the credentials,
and @{text \<open>lgra\<close>} for the state of a location and the data at that location.\<close>
datatype location = Location nat
  datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                           "actor \<Rightarrow> (string set * string set)"
                           "location \<Rightarrow> string * (dlm * data) set"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph, location] \<Rightarrow> policy set"

primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string * (dlm * data) set)"
where  "lgra(Lgraph g a c l) = l"

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

text \<open>There are projection functions text{@ \<open>graphI\<close>} and text{@ \<open>delta\<close>} when applied
to an infrastructure return the graph and the policy, respectively. Other projections
are introduced for the labels, the credential, and roles and to express their meaning.\<close>
primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string * (dlm * data)set"
where "lspace (Infrastructure g d) = lgra g"

definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"
definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s = fst (lgra G l)"

text \<open>Predicates and projections for the labels to encode their meaning.\<close>
definition owner :: "dlm * data \<Rightarrow> actor" where "owner d \<equiv> fst(fst d)"
definition owns :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"
definition readers :: "dlm * data \<Rightarrow> actor set"
  where "readers d \<equiv> snd (fst d)"

text \<open>The predicate @{text \<open>has_access\<close>} is true for owners or readers.\<close>
definition has_access :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

(*
text \<open>Actors can delete data.\<close>
definition actor_can_delete ::   "[infrastructure, actor, location] \<Rightarrow> bool"
where actor_can_delete_def: "actor_can_delete I h l \<equiv>
                   (\<forall> as n. ((h, as), n) \<notin> (snd (lgra (graphI I) l)))"
*)
text \<open>We define a type of functions that preserves the security labeling and a
   corresponding function application  operator.\<close>
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
  by (fastforce)

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" (infixr "\<Updown>" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

(* This part is relevant to model Insiders but is not needed for Infrastructures.

datatype psy_states = happy | depressed | disgruntled | angry | stressed
datatype motivations = financial | political | revenge | curious | competitive_advantage | power | peer_recognition

datatype actor_state = Actor_state "psy_states" "motivations set"
primrec motivation :: "actor_state \<Rightarrow> motivations set"
where "motivation  (Actor_state p m) =  m"
primrec psy_state :: "actor_state \<Rightarrow> psy_states"
where "psy_state  (Actor_state p m) = p"

definition tipping_point :: "actor_state \<Rightarrow> bool" where
  "tipping_point a \<equiv> ((motivation a \<noteq> {}) \<and> (happy \<noteq> psy_state a))"

consts astate :: "identity \<Rightarrow> actor_state"

(* Two versions of an impersonation predicate "a can act as b".
   The first one is stronger and allows substitution of the insider in any context;
   the second one is parameterized over a context predicate to describe this.   *)
definition UasI ::  "[identity, identity] \<Rightarrow> bool "
where "UasI a b \<equiv> (Actor a = Actor b) \<and> (\<forall> x y. x \<noteq> a \<and> y \<noteq> a \<and> Actor x = Actor y \<longrightarrow> x = y)"

definition UasI' ::  "[actor => bool, identity, identity] \<Rightarrow> bool "
where "UasI' P a b \<equiv> P (Actor b) \<longrightarrow> P (Actor a)"

definition Insider :: "[identity, identity set] \<Rightarrow> bool"
where "Insider a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI a b))"

definition Insider' :: "[actor \<Rightarrow> bool, identity, identity set] \<Rightarrow> bool"
where "Insider' P a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI' P a b \<and> inj_on Actor C))"
*)

text \<open>The predicate atI -- mixfix syntax @{text \<open>@\<^bsub>G\<^esub>\<close>} -- expresses that an actor (identity)
      is at a certain location in an igraph.\<close>
definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

text \<open>Policies specify the expected behaviour of actors of an infrastructure.
They are defined by the @{text \<open>enables\<close>} predicate:
an actor @{text \<open>h\<close>} is enabled to perform an action @{text \<open>a\<close>}
in infrastructure @{text \<open>I\<close>}, at location @{text \<open>l\<close>}
if there exists a pair @{text \<open>(p,e)\<close>} in the local policy of @{text \<open>l\<close>}
(@{text \<open>delta I l\<close>} projects to the local policy) such that the action
@{text \<open>a\<close>} is a member of the action set @{text \<open>e\<close>} and the policy
predicate @{text \<open>p\<close>} holds for actor @{text \<open>h\<close>}.\<close>
definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

text \<open>The behaviour is the good behaviour, i.e. everything allowed by the policy of infrastructure I.\<close>
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

text \<open>The misbehaviour is the complement of the behaviour of an infrastructure I.\<close>
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "misbehaviour I \<equiv> -(behaviour I)"

subsection "State transition on infrastructures"
text \<open>The state transition defines how actors may act on infrastructures through actions
    within the boundaries of the policy. It is given as an inductive definition over the
    states which are infrastructures.  This state transition relation is dependent on actions but also on
    enabledness and the current state of the infrastructure.

    First we introduce some auxiliary functions dealing
    with repetitions in lists and actors moving in an igraph.\<close>
primrec jonce :: "['a, 'a list] \<Rightarrow> bool"
where
jonce_nil: "jonce a [] = False" |
jonce_cons: "jonce a (x#ls) = (if x = a then (a \<notin> (set ls)) else jonce a ls)"
(*
primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"
*)
definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)"

inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; a' @\<^bsub>G\<^esub> l; has G (Actor a, z);
        enables I l (Actor a) get;
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)
                           ((cgra G)(Actor a' :=
                                (insert z (fst(cgra G (Actor a'))), snd(cgra G (Actor a')))))
                           (lgra G))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get_data : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l' (Actor a) get \<Longrightarrow>
       ((Actor a', as), n) \<in> snd (lgra G l') \<Longrightarrow> Actor a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l),
                                   snd (lgra G l)  \<union> {((Actor a', as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| process : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l (Actor a) eval \<Longrightarrow>
       ((Actor a', as), n) \<in> snd (lgra G l) \<Longrightarrow> Actor a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l),
                    snd (lgra G l)  - {((Actor a', as), n)}
                    \<union> {(f :: label_fun) \<Updown> ((Actor a', as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| del_data : "G = graphI I \<Longrightarrow> a \<in> actors G \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
       ((Actor a, as), n) \<in> snd (lgra G l) \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l), snd (lgra G l) - {((Actor a, as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> enables I l (Actor a) put \<Longrightarrow>
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                          ((lgra G)(l := (s, snd (lgra G l) \<union> {((Actor a, as), n)}))))
                   (delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

text \<open>Note that the type infrastructure can now be instantiated to the axiomatic type class
      @{text\<open>state\<close>} which enables the use of the underlying Kripke structures and CTL.\<close>
instantiation "infrastructure" :: state
begin
definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

lemma move_graph_eq: "move_graph_a a l l g = g"
  by (simp add: move_graph_a_def, case_tac g, force)

end