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

constdefs
  "derivative" :: "pi \<Rightarrow> pi \<Rightarrow> subject \<Rightarrow> name \<Rightarrow> (pi \<times> pi) set \<Rightarrow> bool"
  "derivative P Q a x Rel \<equiv> case a of InputS b \<Rightarrow> (\<forall>u. (P[x::=u], Q[x::=u]) \<in> Rel)
                                    | BoundOutputS b \<Rightarrow> (P, Q) \<in> Rel"

  "simulation" :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" ("_ \<leadsto>[_] _" [80, 80, 80] 80)
  "P \<leadsto>[Rel] Q \<equiv> (\<forall>a x Q'. Q \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> Q' \<and> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> derivative P' Q' a x Rel)) \<and>
                 (\<forall>\<alpha> Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

  assumes "P \<leadsto>[A] P'"
  and     "A \<subseteq> B"

  shows "P \<leadsto>[B] P'"
proof -
  from prems show ?thesis apply(auto simp add: simulation_def derivative_def)
    by(case_tac a) fastforce+
qed

lemma derivativeMonotonic:
  fixes A :: "(pi \<times> pi) set"
  and   B :: "(pi \<times> pi) set"
  and   P :: pi
  and   Q :: pi
  and   a :: subject
  and   x :: name

  assumes "derivative P Q a x A"
  and     "A \<subseteq> B"

  shows "derivative P Q a x B"
proof -
  from prems show ?thesis
    by(case_tac a, auto simp add: derivative_def)
qed

lemma derivativeEqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: subject
  and   x    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Der: "derivative P Q a x Rel"
  and     Eqvt: "eqvt Rel"

  shows "derivative (perm \<bullet> P) (perm \<bullet> Q) (perm \<bullet> a) (perm \<bullet> x) Rel"
proof -
  from prems show ?thesis
    apply(case_tac a, auto simp add: derivative_def)
    apply(erule_tac x="rev perm \<bullet> u" in allE)
    apply(drule_tac perm=perm in eqvtRelI)
    apply(blast)
    apply(force simp add: eqvt_subs name_per_rev)
    by(force simp add: eqvt_def)
qed

lemma derivativeEqvtI2:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: subject
  and   x    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Der: "derivative P Q a x Rel"
  and     Eqvt: "eqvt Rel"

  shows "derivative (perm \<bullet> P) (perm \<bullet> Q) a (perm \<bullet> x) Rel"
proof -
  from prems show ?thesis
    apply(case_tac a, auto simp add: derivative_def)
    apply(erule_tac x="rev perm \<bullet> u" in allE)
    apply(drule_tac perm=perm in eqvtRelI)
    apply(blast)
    apply(force simp add: eqvt_subs name_per_rev)
    by(force simp add: eqvt_def)
qed

lemma freshUnit[simp]:
  fixes y :: name

  shows "y \<sharp> ()"
by(auto simp add: fresh_def supp_unit)

lemma simCasesCont[consumes 1, case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   C   :: "'a::fs_name"

  assumes Eqvt:  "eqvt Rel"
  and     Bound: "\<And>Q' a y. \<lbrakk>Q \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'; y \<sharp> C\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q' a y Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto>[Rel] Q"
proof -
  from Free show ?thesis
  proof(auto simp add: simulation_def)
    fix Q' a y
    assume yFreshP: "(y::name) \<sharp> P"
    assume Trans: "Q \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'"
    have "\<exists>c::name. c \<sharp> (P, Q', y, C)" by(blast intro: name_exists_fresh)
    then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ': "c \<sharp> Q'" and cFreshC: "c \<sharp> C"
                          and cineqy: "c \<noteq> y"
      by(force simp add: fresh_prod name_fresh)

    from Trans cFreshQ' have "Q \<longmapsto> a\<guillemotleft>c\<guillemotright> \<prec> [(y, c)] \<bullet> Q'" by(simp add: alphaBoundResidual)
    hence "\<exists>P'. P \<longmapsto> a\<guillemotleft>c\<guillemotright> \<prec> P' \<and> derivative P' ([(y, c)] \<bullet> Q') a c Rel" using cFreshC
      by(rule Bound)
    then obtain P' where PTrans: "P \<longmapsto> a\<guillemotleft>c\<guillemotright> \<prec> P'" and PDer: "derivative P' ([(y, c)] \<bullet> Q') a c Rel"
      by blast

    from PTrans yFreshP cineqy have yFreshP': "y \<sharp> P'" by(force intro: freshBoundDerivative)
    with PTrans have "P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> [(y, c)] \<bullet> P'" by(simp add: alphaBoundResidual name_swap)
    moreover have "derivative ([(y, c)] \<bullet> P') Q' a y Rel" (is "?goal")
    proof -
      from PDer Eqvt have "derivative ([(y, c)] \<bullet> P') ([(y, c)] \<bullet> [(y, c)] \<bullet> Q') a ([(y, c)] \<bullet> c) Rel"
        by(rule derivativeEqvtI2)
      with cineqy show ?goal by(simp add: name_calc)
    qed
    ultimately show "\<exists>P'. P \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q' a y Rel" by blast
  qed
qed

lemma simCases[consumes 0, case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes Bound: "\<And>Q' a y. \<lbrakk>Q \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'; y \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q' a y Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto>[Rel] Q"
proof -
  from prems show ?thesis
    by(auto simp add: simulation_def)
qed
(*
lemma inputSimCases[consumes 1, case_names Input]:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   a   :: name
  and   x   :: name
  and   Q   :: pi

  assumes Eqvt: "eqvt Rel"
  and     SC:   "\<forall>P Q. (P, Q) \<in> Rel \<Longrightarrow> (P, Q) \<in> substClosed Rel"
  and     In:   "\<And>Q'. \<exists>P'. P \<longmapsto>a<x> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto>[Rel] a<x>.Q"
proof -
  from Eqvt show ?thesis
  proof(induct rule: simCasesCont[of _ _ "(x, P)"])
    case(Bound Q' a' y)
    have "y \<sharp> (x, P)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" by(simp add: fresh_prod)+
    have "a<x>.Q \<longmapsto>a'\<guillemotleft>y\<guillemotright> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: inputCases)
      assume "a'\<guillemotleft>y\<guillemotright> \<prec> Q' = a<x> \<prec> Q"
      with yineqx have aeqa': "InputS a = a'" and Q'eqQ: "Q' = [(y, x)] \<bullet> Q"
        by(auto simp add: residual.inject name_abs_eq)
      obtain P' where PTrans: "P \<longmapsto>a<x> \<prec> P'" and P'RelQ: "(P', Q) \<in> Rel"
        by(insert In) auto

      have "P \<longmapsto>a<y> \<prec> [(y, x)] \<bullet> P'"
      proof -
        from PTrans yFreshP yineqx have "y \<sharp> P'" by(force dest: freshTransition)
        with PTrans show ?thesis by(simp add: alphaBoundResidual name_swap)
      qed
      moreover from Eqvt P'RelQ have "([(y, x)] \<bullet> P', [(y, x)] \<bullet> Q) \<in> Rel"
        by(rule eqvtRelI)
      ultimately show ?thesis using aeqa' Q'eqQ SC
        apply(auto simp add: derivative_def)
        apply(auto simp add: substClosed_def)
        apply(erule_tac x="[(y, u)]" in allE)
        apply auto
        apply blast
      proof -
        apply(auto)
        have
      thus ?case

*)
lemma resSimCases[consumes 1, case_names BoundOutput BoundR FreeR]:
  fixes x   :: name
  and   P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   C   :: "'a::fs_name"

  assumes Eqvt:    "eqvt Rel"
  and     BoundO:  "\<And>Q' a. \<lbrakk>Q \<longmapsto>a[x] \<prec> Q'; a \<noteq> x\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     BR:      "\<And>Q' a y. \<lbrakk>Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'; x \<sharp> a; x \<noteq> y; y \<sharp> C\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' (<\<nu>x>Q') a y Rel"
  and     BF:      "\<And>Q' \<alpha>. \<lbrakk>Q \<longmapsto>\<alpha> \<prec> Q'; x \<sharp> \<alpha>\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', <\<nu>x>Q') \<in> Rel"

  shows "P \<leadsto>[Rel] <\<nu>x>Q"
proof -
  from Eqvt show ?thesis
  proof(induct rule: simCasesCont[of _ _ "(C, x, P, Q)"])
    case(Bound Q' a y)
    have "y \<sharp> (C, x, P, Q)" by fact
    hence yFreshC: "y \<sharp> C" and yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" and "y \<sharp> Q"
      by(simp add: fresh_prod)+
    have "<\<nu>x>Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'" by fact
    thus ?case using yineqx `y \<sharp> Q`
    proof(induct rule: resCasesB)
      case(cOpen a' Q')
      have "Q \<longmapsto>a'[x] \<prec> Q'" and "a' \<noteq> x" by fact+
      then obtain P' where PTrans: "P \<longmapsto>a'<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by(force dest: BoundO)

      from PTrans yFreshP yineqx have "y \<sharp> P'" by(force dest: freshBoundDerivative)
      with PTrans have "P \<longmapsto>a'<\<nu>y> \<prec> ([(x, y)] \<bullet> P')" by(simp add: alphaBoundResidual)
      moreover from P'RelQ' Eqvt have "([(x, y)] \<bullet> P', [(x, y)] \<bullet> Q') \<in> Rel" by(auto simp add: eqvt_def)
      ultimately show ?case by(force simp add: derivative_def name_swap)
    next
      case(cRes Q')
      have "Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'" and "x \<sharp> a" by fact+
      with yineqx yFreshC show ?case by(force dest: BR)
    qed
  next
    case(Free Q' \<alpha>)
    have "<\<nu>x>Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: resCasesF)
      case(cRes Q')
      have "Q \<longmapsto>\<alpha> \<prec> Q'" and "x \<sharp> \<alpha>" by fact+
      thus ?case by(rule BF)
    qed
  qed
qed

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

  assumes "P \<leadsto>[Rel] Q"

  shows "Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> (derivative P' Q' a x Rel)"
  and   "Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
using prems by(simp add: simulation_def)+

lemma eqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

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

  shows "(perm \<bullet> P) \<leadsto>[Rel'] (perm \<bullet> Q)"
proof -
  show ?thesis
  proof(induct rule: simCases)
    case(Bound Q' a y)
    have QTrans: "(perm \<bullet> Q) \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'" and yFreshP: "y \<sharp> perm \<bullet> P" by fact+

    from QTrans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a\<guillemotleft>y\<guillemotright> \<prec> Q')"
      by(rule transitions.eqvt)
    hence "Q \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>(rev perm \<bullet> y)\<guillemotright> \<prec> (rev perm \<bullet> Q')"
      by(simp add: name_rev_per)
    moreover from yFreshP have "(rev perm \<bullet> y) \<sharp> P" by(simp add: name_fresh_left)
    ultimately have "\<exists>P'. P \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P' \<and> derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel" using Sim
      by(force intro: simE)
    then obtain P' where PTrans: "P \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P'" and Pderivative: "derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel" by blast

    from PTrans have "(perm \<bullet> P) \<longmapsto> perm \<bullet> ((rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P')" by(rule transitions.eqvt)
    hence L1: "(perm \<bullet> P) \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
    from Pderivative RelRel' have "derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel'"
      by(rule derivativeMonotonic)
    hence "derivative (perm \<bullet> P') (perm \<bullet> (rev perm \<bullet> Q')) (perm \<bullet> (rev perm \<bullet> a)) (perm \<bullet> (rev perm \<bullet> y)) Rel'" using EqvtRel'
      by(rule derivativeEqvtI)
    hence "derivative (perm \<bullet> P') Q' a y Rel'" by(simp add: name_per_rev)
    with L1 show ?case by blast
  next
    case(Free Q' \<alpha>)
    have "(perm \<bullet> Q) \<longmapsto> \<alpha> \<prec> Q'" by fact

    hence "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (\<alpha> \<prec> Q')"
      by(rule transitions.eqvt)
    hence "Q \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> (rev perm \<bullet> Q')"
      by(simp add: name_rev_per)
    with Sim have "\<exists>P'. P \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> P' \<and> (P', (rev perm \<bullet> Q')) \<in> Rel"
      by(force intro: simE)
    then obtain P' where PTrans: "P \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> P'" and PRel: "(P', (rev perm \<bullet> Q')) \<in> Rel"
      by blast

    from PTrans have "(perm \<bullet> P) \<longmapsto> perm \<bullet> ((rev perm \<bullet> \<alpha>)\<prec> P')" by(rule transitions.eqvt)
    hence L1: "(perm \<bullet> P) \<longmapsto> \<alpha> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
    from PRel EqvtRel' RelRel'  have "((perm \<bullet> P'), (perm \<bullet> (rev perm \<bullet> Q'))) \<in> Rel'"
      by(force intro: eqvtRelI)
    hence "((perm \<bullet> P'), Q') \<in> Rel'" by(simp add: name_per_rev)
    with L1 show "\<exists>P'. (perm \<bullet> P) \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" by blast
  qed
qed
(*
lemma strongSimI2:
  fixes P   :: pi
  and   Q   :: pi
  and   C   :: "'a::fs_name"
  and   Rel :: "(pi \<times> pi) set"

  assumes "eqvt Rel"
  and     "\<forall>Rs y. Q \<longmapsto> Rs \<longrightarrow> simAct P Rs C Rel"

  shows "P \<leadsto>[Rel] Q"
proof -
  from prems show ?thesis
    apply -
    by(force intro: simCasesCont[of _ _ "(C, P)"] simp add: simAct_def fresh_prod)
qed
*)
lemma derivativeReflexive:
  fixes P   :: pi
  and   a   :: subject
  and   x   :: name
  and   Rel :: "(pi \<times> pi) set"

  assumes "Id \<subseteq> Rel"

  shows "derivative P P a x Rel"
proof -
  from prems show ?thesis
    apply(cases a)
    by(auto simp add: derivative_def)
qed
(*
lemma simActBoundCases[consumes 1, case_names Der]:
  fixes P   :: pi
  and   a   :: subject
  and   x   :: name
  and   Q'  :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes EqvtRel: "eqvt Rel"
  and     Der: "(\<exists>P'. P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> derivative P' Q' a x Rel)"

  shows "simAct P (a\<guillemotleft>x\<guillemotright> \<prec> Q') P Rel"
proof(simp add: simAct_def, auto)
  fix Q'' b y
  assume Eq: "a\<guillemotleft>x\<guillemotright> \<prec> Q' = b\<guillemotleft>y\<guillemotright> \<prec> Q''"
  assume yFreshP: "y \<sharp> P"

  with Der Eq show "\<exists>P'. P \<longmapsto>b\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q'' b y Rel"
  proof(cases "x=y", auto simp add: residual.inject name_abs_eq)
    fix P'
    assume PTrans: "P \<longmapsto>b\<guillemotleft>x\<guillemotright> \<prec> P'"
    assume Der: "derivative P' ([(x, y)] \<bullet> Q'') b x Rel"
    assume xineqy: "x \<noteq> y"

    with PTrans yFreshP have yFreshP': "y \<sharp> P'" by(force intro: freshBoundDerivative)

    hence "b\<guillemotleft>x\<guillemotright> \<prec> P' = b\<guillemotleft>y\<guillemotright> \<prec> [(x, y)] \<bullet> P'" by(rule alphaBoundResidual)
    moreover have "derivative ([(x, y)] \<bullet> P') Q'' b y Rel" (is ?goal)
    proof -
      from Der EqvtRel have "derivative ([(x, y)] \<bullet> P') ([(x, y)] \<bullet> ([(x, y)] \<bullet> Q'')) b ([(x, y)] \<bullet> x) Rel"
        by(rule derivativeEqvtI2)
      thus ?goal by(simp add: name_calc)
    qed

    ultimately show "\<exists>P'. P \<longmapsto>b\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q'' b y Rel" using PTrans by auto
  qed
qed

lemma simActFreeCases[consumes 0, case_names Der]:
  fixes P   :: pi
  and   \<alpha>   :: freeRes
  and   Q'  :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "simAct P (\<alpha> \<prec> Q') P Rel"
proof -
  from prems show ?thesis
    by(simp add: simAct_def residual.inject)
qed
*)
(*****************Reflexivity and transitivity*********************)

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

  assumes "Id \<subseteq> Rel"

  shows "P \<leadsto>[Rel] P"
proof -
  from prems show ?thesis
    by(auto simp add: simulation_def derivativeReflexive)
qed

  assumes PSimQ: "P \<leadsto>[Rel] Q"
  and     QSimR: "Q \<leadsto>[Rel'] R"
  and     Eqvt': "eqvt Rel''"
  and     Trans: "Rel' O Rel \<subseteq> Rel''"

  shows "P \<leadsto>[Rel''] R"
proof -
  from Eqvt' show ?thesis
  proof(induct rule: simCasesCont[of _ _ "(P, Q)"])
    case(Bound R' a x)
    have RTrans: "R \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> R'" by fact
    have "x \<sharp> (P, Q)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

    from xFreshQ QSimR RTrans obtain Q' where QTrans: "Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q'"
                                          and QDer: "derivative Q' R' a x Rel'"
      by(blast dest: simE)
    with QTrans xFreshP PSimQ obtain P' where PTrans: "P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P'"
                                          and PDer: "derivative P' Q' a x Rel"
      by(blast dest: simE)
    moreover from PDer QDer Trans have "derivative P' R' a x Rel''"
      by(cases a, auto simp add: derivative_def)
    ultimately show ?case by blast
  next
    case(Free R' \<alpha>)
    have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
    with QSimR obtain Q' where QTrans: "Q \<longmapsto> \<alpha> \<prec> Q'"
                           and Q'RelR': "(Q', R') \<in> Rel'"
      by(blast dest: simE)
    from QTrans PSimQ obtain P' where PTrans: "P \<longmapsto> \<alpha> \<prec> P'"
                                  and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    with PTrans show ?case by blast
  qed
qed

end


(*  Title:      ZF/Inductive_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Inductive definitions use least fixedpoints with standard products and sums
Coinductive definitions use greatest fixedpoints with Quine products and sums

Sums are used only for mutual recursion;
Products are used only to derive "streamlined" induction rules for relations
*)

section\<open>Inductive and Coinductive Definitions\<close>

theory Inductive_ZF
imports Fixedpt QPair Nat_ZF
keywords
  "inductive" "coinductive" "inductive_cases" "rep_datatype" "primrec" :: thy_decl and
  "domains" "intros" "monos" "con_defs" "type_intros" "type_elims"
    "elimination" "induction" "case_eqns" "recursor_eqns" :: quasi_command
begin

lemma def_swap_iff: "a == b ==> a = c \<longleftrightarrow> c = b"
  by blast

lemma def_trans: "f == g ==> g(a) = b ==> f(a) = b"
  by simp

lemma refl_thin: "!!P. a = a ==> P ==> P" .

ML_file "ind_syntax.ML"
ML_file "Tools/ind_cases.ML"
ML_file "Tools/cartprod.ML"
ML_file "Tools/inductive_package.ML"
ML_file "Tools/induct_tacs.ML"
ML_file "Tools/primrec_package.ML"

ML \<open>
structure Lfp =
  struct
  val oper      = @{const lfp}
  val bnd_mono  = @{const bnd_mono}
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_lfp_subset}
  val Tarski    = @{thm def_lfp_unfold}
  val induct    = @{thm def_induct}
  end;

structure Standard_Prod =
  struct
  val sigma     = @{const Sigma}
  val pair      = @{const Pair}
  val split_name = @{const_name split}
  val pair_iff  = @{thm Pair_iff}
  val split_eq  = @{thm split}
  val fsplitI   = @{thm splitI}
  val fsplitD   = @{thm splitD}
  val fsplitE   = @{thm splitE}
  end;

structure Standard_CP = CartProd_Fun (Standard_Prod);

structure Standard_Sum =
  struct
  val sum       = @{const sum}
  val inl       = @{const Inl}
  val inr       = @{const Inr}
  val elim      = @{const case}
  val case_inl  = @{thm case_Inl}
  val case_inr  = @{thm case_Inr}
  val inl_iff   = @{thm Inl_iff}
  val inr_iff   = @{thm Inr_iff}
  val distinct  = @{thm Inl_Inr_iff}
  val distinct' = @{thm Inr_Inl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Standard_Prod.pair_iff]
  end;

structure Ind_Package =
    Add_inductive_def_Fun
      (structure Fp=Lfp and Pr=Standard_Prod and CP=Standard_CP
       and Su=Standard_Sum val coind = false);

structure Gfp =
  struct
  val oper      = @{const gfp}
  val bnd_mono  = @{const bnd_mono}
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_gfp_subset}
  val Tarski    = @{thm def_gfp_unfold}
  val induct    = @{thm def_Collect_coinduct}
  end;

structure Quine_Prod =
  struct
  val sigma     = @{const QSigma}
  val pair      = @{const QPair}
  val split_name = @{const_name qsplit}
  val pair_iff  = @{thm QPair_iff}
  val split_eq  = @{thm qsplit}
  val fsplitI   = @{thm qsplitI}
  val fsplitD   = @{thm qsplitD}
  val fsplitE   = @{thm qsplitE}
  end;

structure Quine_CP = CartProd_Fun (Quine_Prod);

structure Quine_Sum =
  struct
  val sum       = @{const qsum}
  val inl       = @{const QInl}
  val inr       = @{const QInr}
  val elim      = @{const qcase}
  val case_inl  = @{thm qcase_QInl}
  val case_inr  = @{thm qcase_QInr}
  val inl_iff   = @{thm QInl_iff}
  val inr_iff   = @{thm QInr_iff}
  val distinct  = @{thm QInl_QInr_iff}
  val distinct' = @{thm QInr_QInl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Quine_Prod.pair_iff]
  end;

structure CoInd_Package =
  Add_inductive_def_Fun(structure Fp=Gfp and Pr=Quine_Prod and CP=Quine_CP
    and Su=Quine_Sum val coind = true);

\<close>

end


(*  Title:      Sequents/Modal0.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory Modal0
imports LK0
begin

ML_file \<open>modal.ML\<close>

consts
  box           :: "o\<Rightarrow>o"       ("[]_" [50] 50)
  dia           :: "o\<Rightarrow>o"       ("<>_" [50] 50)
  Lstar         :: "two_seqi"
  Rstar         :: "two_seqi"

syntax
  "_Lstar"      :: "two_seqe"   ("(_)|L>(_)" [6,6] 5)
  "_Rstar"      :: "two_seqe"   ("(_)|R>(_)" [6,6] 5)

ML \<open>
  fun star_tr c [s1, s2] = Const(c, dummyT) $ seq_tr s1 $ seq_tr s2;
  fun star_tr' c [s1, s2] = Const(c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
\<close>

parse_translation \<open>
 [(\<^syntax_const>\<open>_Lstar\<close>, K (star_tr \<^const_syntax>\<open>Lstar\<close>)),
  (\<^syntax_const>\<open>_Rstar\<close>, K (star_tr \<^const_syntax>\<open>Rstar\<close>))]
\<close>

print_translation \<open>
 [(\<^const_syntax>\<open>Lstar\<close>, K (star_tr' \<^syntax_const>\<open>_Lstar\<close>)),
  (\<^const_syntax>\<open>Rstar\<close>, K (star_tr' \<^syntax_const>\<open>_Rstar\<close>))]
\<close>

definition strimp :: "[o,o]\<Rightarrow>o"   (infixr "--<" 25)
  where "P --< Q == [](P \<longrightarrow> Q)"

definition streqv :: "[o,o]\<Rightarrow>o"   (infixr ">-<" 25)
  where "P >-< Q == (P --< Q) \<and> (Q --< P)"

lemmas rewrite_rls = strimp_def streqv_def

lemma iffR: "\<lbrakk>$H,P \<turnstile> $E,Q,$F;  $H,Q \<turnstile> $E,P,$F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P \<longleftrightarrow> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL: "\<lbrakk>$H,$G \<turnstile> $E,P,Q;  $H,Q,P,$G \<turnstile> $E \<rbrakk> \<Longrightarrow> $H, P \<longleftrightarrow> Q, $G \<turnstile> $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemmas safe_rls = basic conjL conjR disjL disjR impL impR notL notR iffL iffR
  and unsafe_rls = allR exL
  and bound_rls = allL exR

end


(* Title: Unpredictable_Function.thy
  Author: Andreas Lochbihler, ETH Zurich
  Author: S. Reza Sefidgar, ETH Zurich *)

subsection \<open>Unpredictable function\<close>

theory Unpredictable_Function imports
  Guessing_Many_One
begin

locale upf =
  fixes key_gen :: "'key spmf"
  and hash :: "'key \<Rightarrow> 'x \<Rightarrow> 'hash"
begin

type_synonym ('x', 'hash') adversary = "(unit, 'x' + ('x' \<times> 'hash'), 'hash' + unit) gpv"

definition oracle_hash :: "'key \<Rightarrow> ('x, 'hash, 'x set) callee"
where
  "oracle_hash k = (\<lambda>L y. do {
    let t = hash k y;
    let L = insert y L;
    return_spmf (t, L)
  })"

definition oracle_flag :: "'key \<Rightarrow> ('x \<times> 'hash, unit, bool \<times> 'x set) callee"
where
  "oracle_flag = (\<lambda>key (flg, L) (y, t).
    return_spmf ((), (flg \<or> (t = (hash key y) \<and> y \<notin> L), L)))"

abbreviation "oracle" :: "'key \<Rightarrow> ('x + 'x \<times> 'hash, 'hash + unit, bool \<times> 'x set) callee"
where "oracle key \<equiv> \<dagger>(oracle_hash key) \<oplus>\<^sub>O oracle_flag key"

definition game :: "('x, 'hash) adversary \<Rightarrow> bool spmf"
where
  "game \<A> = do {
    key \<leftarrow> key_gen;
    (_, (flag', L')) \<leftarrow> exec_gpv (oracle key) \<A> (False, {});
    return_spmf flag'
  }"

definition advantage :: "('x, 'hash) adversary \<Rightarrow> real"
where "advantage \<A> = spmf (game \<A>) True"

type_synonym ('x', 'hash') adversary1 = "('x' \<times> 'hash', 'x', 'hash') gpv"

definition game1 :: "('x, 'hash) adversary1 \<Rightarrow> bool spmf"
where
  "game1 \<A> = do {
    key \<leftarrow> key_gen;
    ((m, h), L) \<leftarrow> exec_gpv (oracle_hash key) \<A> {};
    return_spmf (h = hash key m \<and> m \<notin> L)
  }"

definition advantage1 :: "('x, 'hash) adversary1 \<Rightarrow> real"
  where "advantage1 \<A> = spmf (game1 \<A>) True"

lemma advantage_advantage1:
  assumes bound: "interaction_bounded_by (Not \<circ> isl) \<A> q"
  shows "advantage \<A> \<le> advantage1 (guessing_many_one.reduction q (\<lambda>_ :: unit. \<A>) ()) * q"
proof -
  let ?init = "map_spmf (\<lambda>key. (key, (), {})) key_gen"
  let ?oracle = "\<lambda>key . oracle_hash key"
  let ?eval = "\<lambda>key (_ :: unit) L (x, h). return_spmf (h = hash key x \<and> x \<notin> L)"

  interpret guessing_many_one ?init ?oracle ?eval .

  have [simp]: "oracle_flag key = eval_oracle key ()" for key
    by(simp add: oracle_flag_def eval_oracle_def fun_eq_iff)
  have "game \<A> = game_multi (\<lambda>_. \<A>)"
    by(auto simp add: game_multi_def game_def bind_map_spmf intro!: bind_spmf_cong[OF refl])
  hence "advantage \<A> = advantage_multi (\<lambda>_. \<A>)" by(simp add: advantage_def advantage_multi_def)
  also have "\<dots> \<le> advantage_single (reduction q (\<lambda>_. \<A>)) * q" using bound
    by(rule many_single_reduction)(auto simp add: oracle_hash_def)
  also have "advantage_single (reduction q (\<lambda>_. \<A>)) = advantage1 (reduction q (\<lambda>_. \<A>) ())" for \<A>
    unfolding advantage1_def advantage_single_def
    by(auto simp add: game1_def game_single_def bind_map_spmf o_def intro!: bind_spmf_cong[OF refl] arg_cong2[where f=spmf])
  finally show ?thesis .
qed

end

end