(*  Title:      HOL/BNF_Fixpoint_Base.thy
    Author:     Lorenz Panny, TU Muenchen
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Author:     Martin Desharnais, TU Muenchen
    Copyright   2012, 2013, 2014

Shared fixpoint operations on bounded natural functors.
*)

section {* Shared Fixpoint Operations on Bounded Natural Functors *}

theory BNF_Fixpoint_Base
imports BNF_Composition Basic_BNFs
begin

lemma False_imp_eq_True: "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
  by default simp_all

lemma conj_imp_eq_imp_imp: "(P \<and> Q \<Longrightarrow> PROP R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> PROP R)"
  by default simp_all

lemma mp_conj: "(P \<longrightarrow> Q) \<and> R \<Longrightarrow> P \<Longrightarrow> R \<and> Q"
  by auto

lemma predicate2D_conj: "P \<le> Q \<and> R \<Longrightarrow> P x y \<Longrightarrow> R \<and> Q x y"
  by auto

lemma eq_sym_Unity_conv: "(x = (() = ())) = x"
  by blast

lemma case_unit_Unity: "(case u of () \<Rightarrow> f) = f"
  by (cases u) (hypsubst, rule unit.case)

lemma case_prod_Pair_iden: "(case p of (x, y) \<Rightarrow> (x, y)) = p"
  by simp

lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
  by simp

lemma pointfree_idE: "f \<circ> g = id \<Longrightarrow> f (g x) = x"
  unfolding comp_def fun_eq_iff by simp

lemma o_bij:
  assumes gf: "g \<circ> f = id" and fg: "f \<circ> g = id"
  shows "bij f"
unfolding bij_def inj_on_def surj_def proof safe
  fix a1 a2 assume "f a1 = f a2"
  hence "g ( f a1) = g (f a2)" by simp
  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
next
  fix b
  have "b = f (g b)"
  using fg unfolding fun_eq_iff by simp
  thus "EX a. b = f a" by blast
qed

lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X"
  by simp

lemma case_sum_step:
  "case_sum (case_sum f' g') g (Inl p) = case_sum f' g' p"
  "case_sum f (case_sum f' g') (Inr p) = case_sum f' g' p"
  by auto

lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
  by blast

lemma type_copy_obj_one_point_absE:
  assumes "type_definition Rep Abs UNIV" "\<forall>x. s = Abs x \<longrightarrow> P" shows P
  using type_definition.Rep_inverse[OF assms(1)]
  by (intro mp[OF spec[OF assms(2), of "Rep s"]]) simp

lemma obj_sumE_f:
  assumes "\<forall>x. s = f (Inl x) \<longrightarrow> P" "\<forall>x. s = f (Inr x) \<longrightarrow> P"
  shows "\<forall>x. s = f x \<longrightarrow> P"
proof
  fix x from assms show "s = f x \<longrightarrow> P" by (cases x) auto
qed

lemma case_sum_if:
  "case_sum f g (if p then Inl x else Inr y) = (if p then f x else g y)"
  by simp

lemma prod_set_simps:
  "fsts (x, y) = {x}"
  "snds (x, y) = {y}"
  unfolding prod_set_defs by simp+

lemma sum_set_simps:
  "setl (Inl x) = {x}"
  "setl (Inr x) = {}"
  "setr (Inl x) = {}"
  "setr (Inr x) = {x}"
  unfolding sum_set_defs by simp+

lemma Inl_Inr_False: "(Inl x = Inr y) = False"
  by simp

lemma Inr_Inl_False: "(Inr x = Inl y) = False"
  by simp

lemma spec2: "\<forall>x y. P x y \<Longrightarrow> P x y"
  by blast

lemma rewriteR_comp_comp: "\<lbrakk>g \<circ> h = r\<rbrakk> \<Longrightarrow> f \<circ> g \<circ> h = f \<circ> r"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteR_comp_comp2: "\<lbrakk>g \<circ> h = r1 \<circ> r2; f \<circ> r1 = l\<rbrakk> \<Longrightarrow> f \<circ> g \<circ> h = l \<circ> r2"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteL_comp_comp: "\<lbrakk>f \<circ> g = l\<rbrakk> \<Longrightarrow> f \<circ> (g \<circ> h) = l \<circ> h"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteL_comp_comp2: "\<lbrakk>f \<circ> g = l1 \<circ> l2; l2 \<circ> h = r\<rbrakk> \<Longrightarrow> f \<circ> (g \<circ> h) = l1 \<circ> r"
  unfolding comp_def fun_eq_iff by auto

lemma convol_o: "\<langle>f, g\<rangle> \<circ> h = \<langle>f \<circ> h, g \<circ> h\<rangle>"
  unfolding convol_def by auto

lemma map_prod_o_convol: "map_prod h1 h2 \<circ> \<langle>f, g\<rangle> = \<langle>h1 \<circ> f, h2 \<circ> g\<rangle>"
  unfolding convol_def by auto

lemma map_prod_o_convol_id: "(map_prod f id \<circ> \<langle>id, g\<rangle>) x = \<langle>id \<circ> f, g\<rangle> x"
  unfolding map_prod_o_convol id_comp comp_id ..

lemma o_case_sum: "h \<circ> case_sum f g = case_sum (h \<circ> f) (h \<circ> g)"
  unfolding comp_def by (auto split: sum.splits)

lemma case_sum_o_map_sum: "case_sum f g \<circ> map_sum h1 h2 = case_sum (f \<circ> h1) (g \<circ> h2)"
  unfolding comp_def by (auto split: sum.splits)

lemma case_sum_o_map_sum_id: "(case_sum id g \<circ> map_sum f id) x = case_sum (f \<circ> id) g x"
  unfolding case_sum_o_map_sum id_comp comp_id ..

lemma rel_fun_def_butlast:
  "rel_fun R (rel_fun S T) f g = (\<forall>x y. R x y \<longrightarrow> (rel_fun S T) (f x) (g y))"
  unfolding rel_fun_def ..

lemma subst_eq_imp: "(\<forall>a b. a = b \<longrightarrow> P a b) \<equiv> (\<forall>a. P a a)"
  by auto

lemma eq_subset: "op = \<le> (\<lambda>a b. P a b \<or> a = b)"
  by auto

lemma eq_le_Grp_id_iff: "(op = \<le> Grp (Collect R) id) = (All R)"
  unfolding Grp_def id_apply by blast

lemma Grp_id_mono_subst: "(\<And>x y. Grp P id x y \<Longrightarrow> Grp Q id (f x) (f y)) \<equiv>
   (\<And>x. x \<in> P \<Longrightarrow> f x \<in> Q)"
  unfolding Grp_def by rule auto

lemma vimage2p_mono: "vimage2p f g R x y \<Longrightarrow> R \<le> S \<Longrightarrow> vimage2p f g S x y"
  unfolding vimage2p_def by blast

lemma vimage2p_refl: "(\<And>x. R x x) \<Longrightarrow> vimage2p f f R x x"
  unfolding vimage2p_def by auto

lemma
  assumes "type_definition Rep Abs UNIV"
  shows type_copy_Rep_o_Abs: "Rep \<circ> Abs = id" and type_copy_Abs_o_Rep: "Abs \<circ> Rep = id"
  unfolding fun_eq_iff comp_apply id_apply
    type_definition.Abs_inverse[OF assms UNIV_I] type_definition.Rep_inverse[OF assms] by simp_all

lemma type_copy_map_comp0_undo:
  assumes "type_definition Rep Abs UNIV"
          "type_definition Rep' Abs' UNIV"
          "type_definition Rep'' Abs'' UNIV"
  shows "Abs' \<circ> M \<circ> Rep'' = (Abs' \<circ> M1 \<circ> Rep) \<circ> (Abs \<circ> M2 \<circ> Rep'') \<Longrightarrow> M1 \<circ> M2 = M"
  by (rule sym) (auto simp: fun_eq_iff type_definition.Abs_inject[OF assms(2) UNIV_I UNIV_I]
    type_definition.Abs_inverse[OF assms(1) UNIV_I]
    type_definition.Abs_inverse[OF assms(3) UNIV_I] dest: spec[of _ "Abs'' x" for x])

lemma vimage2p_id: "vimage2p id id R = R"
  unfolding vimage2p_def by auto

lemma vimage2p_comp: "vimage2p (f1 \<circ> f2) (g1 \<circ> g2) = vimage2p f2 g2 \<circ> vimage2p f1 g1"
  unfolding fun_eq_iff vimage2p_def o_apply by simp

lemma vimage2p_rel_fun: "rel_fun (vimage2p f g R) R f g"
  unfolding rel_fun_def vimage2p_def by auto

lemma fun_cong_unused_0: "f = (\<lambda>x. g) \<Longrightarrow> f (\<lambda>x. 0) = g"
  by (erule arg_cong)

lemma inj_on_convol_ident: "inj_on (\<lambda>x. (x, f x)) X"
  unfolding inj_on_def by simp

lemma map_sum_if_distrib_then:
  "\<And>f g e x y. map_sum f g (if e then Inl x else y) = (if e then Inl (f x) else map_sum f g y)"
  "\<And>f g e x y. map_sum f g (if e then Inr x else y) = (if e then Inr (g x) else map_sum f g y)"
  by simp_all

lemma map_sum_if_distrib_else:
  "\<And>f g e x y. map_sum f g (if e then x else Inl y) = (if e then map_sum f g x else Inl (f y))"
  "\<And>f g e x y. map_sum f g (if e then x else Inr y) = (if e then map_sum f g x else Inr (g y))"
  by simp_all

lemma case_prod_app: "case_prod f x y = case_prod (\<lambda>l r. f l r y) x"
  by (case_tac x) simp

lemma case_sum_map_sum: "case_sum l r (map_sum f g x) = case_sum (l \<circ> f) (r \<circ> g) x"
  by (case_tac x) simp+

lemma case_sum_transfer:
  "rel_fun (rel_fun R T) (rel_fun (rel_fun S T) (rel_fun (rel_sum R S) T)) case_sum case_sum"
  unfolding rel_fun_def by (auto split: sum.splits)

lemma case_prod_map_prod: "case_prod h (map_prod f g x) = case_prod (\<lambda>l r. h (f l) (g r)) x"
  by (case_tac x) simp+

lemma case_prod_o_map_prod: "case_prod f \<circ> map_prod g1 g2 = case_prod (\<lambda>l r. f (g1 l) (g2 r))"
  unfolding comp_def by auto

lemma case_prod_transfer:
  "(rel_fun (rel_fun A (rel_fun B C)) (rel_fun (rel_prod A B) C)) case_prod case_prod"
  unfolding rel_fun_def by simp

lemma eq_ifI: "(P \<longrightarrow> t = u1) \<Longrightarrow> (\<not> P \<longrightarrow> t = u2) \<Longrightarrow> t = (if P then u1 else u2)"
  by simp

lemma comp_transfer:
  "rel_fun (rel_fun B C) (rel_fun (rel_fun A B) (rel_fun A C)) (op \<circ>) (op \<circ>)"
  unfolding rel_fun_def by simp

lemma If_transfer: "rel_fun (op =) (rel_fun A (rel_fun A A)) If If"
  unfolding rel_fun_def by simp

lemma Abs_transfer:
  assumes type_copy1: "type_definition Rep1 Abs1 UNIV"
  assumes type_copy2: "type_definition Rep2 Abs2 UNIV"
  shows "rel_fun R (vimage2p Rep1 Rep2 R) Abs1 Abs2"
  unfolding vimage2p_def rel_fun_def
    type_definition.Abs_inverse[OF type_copy1 UNIV_I]
    type_definition.Abs_inverse[OF type_copy2 UNIV_I] by simp

lemma Inl_transfer:
  "rel_fun S (rel_sum S T) Inl Inl"
  by auto

lemma Inr_transfer:
  "rel_fun T (rel_sum S T) Inr Inr"
  by auto

lemma Pair_transfer: "rel_fun A (rel_fun B (rel_prod A B)) Pair Pair"
  unfolding rel_fun_def by simp

ML_file "Tools/BNF/bnf_fp_util.ML"
ML_file "Tools/BNF/bnf_fp_def_sugar_tactics.ML"
ML_file "Tools/BNF/bnf_fp_def_sugar.ML"
ML_file "Tools/BNF/bnf_fp_n2m_tactics.ML"
ML_file "Tools/BNF/bnf_fp_n2m.ML"
ML_file "Tools/BNF/bnf_fp_n2m_sugar.ML"

end


(*  Title:      Atoms
    Authors:    Brian Huffman, Christian Urban

    Instantiations of concrete atoms
*)

theory Atoms
imports Nominal2_Base
begin

section \<open>@{const nat_of} is an example of a function
  without finite support\<close>

lemma not_fresh_nat_of:
  shows "\<not> a \<sharp> nat_of"
unfolding fresh_def supp_def
proof (clarsimp)
  assume "finite {b. (a \<rightleftharpoons> b) \<bullet> nat_of \<noteq> nat_of}"
  hence "finite ({a} \<union> {b. (a \<rightleftharpoons> b) \<bullet> nat_of \<noteq> nat_of})"
    by simp
  then obtain b where
    b1: "b \<noteq> a" and
    b2: "sort_of b = sort_of a" and
    b3: "(a \<rightleftharpoons> b) \<bullet> nat_of = nat_of"
    by (rule obtain_atom) auto
  have "nat_of a = (a \<rightleftharpoons> b) \<bullet> (nat_of a)" by (simp add: permute_nat_def)
  also have "\<dots> = ((a \<rightleftharpoons> b) \<bullet> nat_of) ((a \<rightleftharpoons> b) \<bullet> a)" by (simp add: permute_fun_app_eq)
  also have "\<dots> = nat_of ((a \<rightleftharpoons> b) \<bullet> a)" using b3 by simp
  also have "\<dots> = nat_of b" using b2 by simp
  finally have "nat_of a = nat_of b" by simp
  with b2 have "a = b" by (simp add: atom_components_eq_iff)
  with b1 show "False" by simp
qed

lemma supp_nat_of:
  shows "supp nat_of = UNIV"
  using not_fresh_nat_of [unfolded fresh_def] by auto

section \<open>Manual instantiation of class \<open>at\<close>.\<close>

typedef name = "{a. sort_of a = Sort ''name'' []}"
by (rule exists_eq_simple_sort)

instantiation name :: at
begin

definition
  "p \<bullet> a = Abs_name (p \<bullet> Rep_name a)"

definition
  "atom a = Rep_name a"

instance
apply (rule at_class)
apply (rule type_definition_name)
apply (rule atom_name_def)
apply (rule permute_name_def)
done

end

lemma sort_of_atom_name:
  shows "sort_of (atom (a::name)) = Sort ''name'' []"
  by (simp add: atom_name_def Rep_name[simplified])

text \<open>Custom syntax for concrete atoms of type at\<close>

term "a:::name"

section \<open>Automatic instantiation of class \<open>at\<close>.\<close>

atom_decl name2

lemma
  "sort_of (atom (a::name2)) \<noteq> sort_of (atom (b::name))"
by (simp add: sort_of_atom_name)

text \<open>example swappings\<close>
lemma
  fixes a b::"atom"
  assumes "sort_of a = sort_of b"
  shows "(a \<rightleftharpoons> b) \<bullet> (a, b) = (b, a)"
using assms
by simp

lemma
  fixes a b::"name2"
  shows "(a \<leftrightarrow> b) \<bullet> (a, b) = (b, a)"
by simp

section \<open>An example for multiple-sort atoms\<close>

datatype ty =
  TVar string
| Fun ty ty ("_ \<rightarrow> _")

primrec
  sort_of_ty::"ty \<Rightarrow> atom_sort"
where
  "sort_of_ty (TVar s) = Sort ''TVar'' [Sort s []]"
| "sort_of_ty (Fun ty1 ty2) = Sort ''Fun'' [sort_of_ty ty1, sort_of_ty ty2]"

lemma sort_of_ty_eq_iff:
  shows "sort_of_ty x = sort_of_ty y \<longleftrightarrow> x = y"
apply(induct x arbitrary: y)
apply(case_tac [!] y)
apply(simp_all)
done

declare sort_of_ty.simps [simp del]

typedef var = "{a. sort_of a \<in> range sort_of_ty}"
  by (rule_tac x="Atom (sort_of_ty x) y" in exI, simp)

instantiation var :: at_base
begin

definition
  "p \<bullet> a = Abs_var (p \<bullet> Rep_var a)"

definition
  "atom a = Rep_var a"

instance
apply (rule at_base_class)
apply (rule type_definition_var)
apply (rule atom_var_def)
apply (rule permute_var_def)
done

end

text \<open>Constructor for variables.\<close>

definition
  Var :: "nat \<Rightarrow> ty \<Rightarrow> var"
where
  "Var x t = Abs_var (Atom (sort_of_ty t) x)"

lemma Var_eq_iff [simp]:
  shows "Var x s = Var y t \<longleftrightarrow> x = y \<and> s = t"
  unfolding Var_def
  by (auto simp add: Abs_var_inject sort_of_ty_eq_iff)

lemma sort_of_atom_var [simp]:
  "sort_of (atom (Var n ty)) = sort_of_ty ty"
  unfolding atom_var_def Var_def
  by (simp add: Abs_var_inverse)

lemma
  assumes "\<alpha> \<noteq> \<beta>"
  shows "(Var x \<alpha> \<leftrightarrow> Var y \<alpha>) \<bullet> (Var x \<alpha>, Var x \<beta>) = (Var y \<alpha>, Var x \<beta>)"
  using assms by simp

text \<open>Projecting out the type component of a variable.\<close>

definition
  ty_of :: "var \<Rightarrow> ty"
where
  "ty_of x = inv sort_of_ty (sort_of (atom x))"

text \<open>
  Functions @{term Var}/@{term ty_of} satisfy many of the same
  properties as @{term Atom}/@{term sort_of}.
\<close>

lemma ty_of_Var [simp]:
  shows "ty_of (Var x t) = t"
  unfolding ty_of_def
  unfolding sort_of_atom_var
  apply (rule inv_f_f)
  apply (simp add: inj_on_def sort_of_ty_eq_iff)
  done

lemma ty_of_permute [simp]:
  shows "ty_of (p \<bullet> x) = ty_of x"
  unfolding ty_of_def
  unfolding atom_eqvt [symmetric]
  by (simp only: sort_of_permute)

section \<open>Tests with subtyping and automatic coercions\<close>

declare [[coercion_enabled]]

atom_decl var1
atom_decl var2

declare [[coercion "atom::var1\<Rightarrow>atom"]]

declare [[coercion "atom::var2\<Rightarrow>atom"]]

lemma
  fixes a::"var1" and b::"var2"
  shows "a \<sharp> t \<and> b \<sharp> t"
oops

(* does not yet work: it needs image as
   coercion map *)

lemma
  fixes as::"var1 set"
  shows "atom ` as \<sharp>* t"

oops

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Struct_Cong
  imports Weak_Bisim_Pres Bisim_Struct_Cong
begin

context env begin

lemma weakBisimParComm:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> Q \<approx> Q \<parallel> P"
by(metis bisimParComm strongBisimWeakBisim)

lemma weakBisimResComm:
  fixes x :: name
  and   \<Psi> :: 'b
  and   y :: name
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "y \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) \<approx> \<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisimResComm strongBisimWeakBisim)

lemma weakBisimResComm':
  fixes x    :: name
  and   \<Psi>   :: 'b
  and   xvec :: "name list"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec\<rparr>P) \<approx> \<lparr>\<nu>*xvec\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisimResComm' strongBisimWeakBisim)

lemma weakBisimScopeExt:
  fixes x :: name
  and   \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<approx> P \<parallel> \<lparr>\<nu>x\<rparr>Q"
using assms
by(metis bisimScopeExt strongBisimWeakBisim)

lemma weakBisimScopeExtChain:
  fixes xvec :: "name list"
  and   \<Psi>    :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<approx> P \<parallel> (\<lparr>\<nu>*xvec\<rparr>Q)"
using assms
by(metis bisimScopeExtChain strongBisimWeakBisim)

lemma weakBisimParAssoc:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> (P \<parallel> Q) \<parallel> R \<approx> P \<parallel> (Q \<parallel> R)"
by(metis bisimParAssoc strongBisimWeakBisim)

lemma weakBisimParNil:
  fixes P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<approx> P"
by(metis bisimParNil strongBisimWeakBisim)

lemma weakBisimResNil:
  fixes x :: name
  and   \<Psi> :: 'b

  assumes "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>\<zero> \<approx> \<zero>"
using assms
by(metis bisimResNil strongBisimWeakBisim)

lemma weakBisimOutputPushRes:
  fixes x :: name
  and   \<Psi> :: 'b
  and   M :: 'a
  and   N :: 'a
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P) \<approx> M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisimOutputPushRes strongBisimWeakBisim)

lemma weakBisimInputPushRes:
  fixes x    :: name
  and   \<Psi>    :: 'b
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P) \<approx> M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisimInputPushRes strongBisimWeakBisim)

lemma weakBisimCasePushRes:
  fixes x  :: name
  and   \<Psi>  :: 'b
  and   Cs :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> (map fst Cs)"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(Cases Cs) \<approx> Cases(map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs)"
using assms
by(metis bisimCasePushRes strongBisimWeakBisim)

lemma weakBangExt:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<approx> P \<parallel> !P"
using assms
by(metis bangExt strongBisimWeakBisim)

lemma weakBisimParSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
using assms
by(metis weakBisimParComm weakBisimParPres weakBisimTransitive)

lemma weakBisimScopeExtSym:
  fixes x :: name
  and   Q :: "('a, 'b, 'c) psi"
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<approx> (\<lparr>\<nu>x\<rparr>P) \<parallel> Q"
using assms
by(metis weakBisimScopeExt weakBisimTransitive weakBisimParComm weakBisimE weakBisimResPres)

lemma weakBisimScopeExtChainSym:
  fixes xvec :: "name list"
  and   Q    :: "('a, 'b, 'c) psi"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<approx> (\<lparr>\<nu>*xvec\<rparr>P) \<parallel> Q"
using assms
by(induct xvec) (auto intro: weakBisimScopeExtSym weakBisimReflexive weakBisimTransitive weakBisimResPres)

lemma weakBisimParPresAuxSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
  and     "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
  and     "A\<^sub>R \<sharp>* \<Psi>"
  and     "A\<^sub>R \<sharp>* P"
  and     "A\<^sub>R \<sharp>* Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
using assms
by(metis weakBisimParComm weakBisimParPresAux weakBisimTransitive)

lemma weakBisimParPresSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
using assms
by(metis weakBisimParComm weakBisimParPres weakBisimTransitive)

lemma guardedFrameStatEq:
  fixes P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "extractFrame P \<simeq>\<^sub>F \<langle>\<epsilon>, \<one>\<rangle>"
proof -
  obtain A\<^sub>P \<Psi>\<^sub>P where FrR: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>"
    by(rule freshFrame)

  with \<open>guarded P\<close> have "\<Psi>\<^sub>P \<simeq> \<one>" and "((supp \<Psi>\<^sub>P)::name set) = {}"
    by(metis guardedStatEq)+
  from \<open>supp \<Psi>\<^sub>P = {}\<close> have "A\<^sub>P \<sharp>* \<Psi>\<^sub>P" by(auto simp add: fresh_star_def fresh_def)
  hence "\<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>[], \<Psi>\<^sub>P\<rangle>" by(force intro: frameResFreshChain)
  moreover from \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> have  "\<langle>[], \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>[], \<one>\<rangle>"
    by(simp add: FrameStatEq_def FrameStatImp_def AssertionStatEq_def AssertionStatImp_def)
  ultimately show ?thesis using FrR by(rule_tac FrameStatEqTrans) auto
qed

lemma guardedInsertAssertion:
  fixes P :: "('a, 'b, 'c) psi"
  and   \<Psi> :: 'b

  assumes "guarded P"

  shows "insertAssertion (extractFrame P) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>"
proof -
  obtain A\<^sub>P \<Psi>\<^sub>P where FrR: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* \<Psi>"
    by(rule freshFrame)

  with \<open>guarded P\<close> have "\<Psi>\<^sub>P \<simeq> \<one>" and "((supp \<Psi>\<^sub>P)::name set) = {}"
    by(metis guardedStatEq)+
  from \<open>supp \<Psi>\<^sub>P = {}\<close> have "A\<^sub>P \<sharp>* \<Psi>\<^sub>P" by(auto simp add: fresh_star_def fresh_def)
  hence "\<langle>A\<^sub>P, \<Psi> \<otimes> \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>[], \<Psi> \<otimes> \<Psi>\<^sub>P\<rangle>" using \<open>A\<^sub>P \<sharp>* \<Psi>\<close> by(force intro: frameResFreshChain)
  moreover from \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> have  "\<langle>\<epsilon>, \<Psi> \<otimes> \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi> \<otimes> \<one>\<rangle>" by(force intro: compositionSym)
  moreover have "\<langle>\<epsilon>, \<Psi> \<otimes> \<one>\<rangle> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(force intro: Identity)
  ultimately show ?thesis using FrR \<open>A\<^sub>P \<sharp>* \<Psi>\<close>
    by(force intro: FrameStatEqTrans AssertionStatEqTrans)
qed

lemma insertDoubleAssertionStatEq':
  fixes F  :: "'b frame"
  and   \<Psi>  :: 'b
  and   \<Psi>' :: 'b

  shows "insertAssertion(insertAssertion F \<Psi>) \<Psi>' \<simeq>\<^sub>F (insertAssertion F) (\<Psi>' \<otimes> \<Psi>)"
proof -
  obtain A\<^sub>F \<Psi>\<^sub>F where "F = \<langle>A\<^sub>F, \<Psi>\<^sub>F\<rangle>" and "A\<^sub>F \<sharp>* \<Psi>" and "A\<^sub>F \<sharp>* \<Psi>'" and "A\<^sub>F \<sharp>* (\<Psi>' \<otimes> \<Psi>)"
    by(rule_tac C="(\<Psi>, \<Psi>')" in freshFrame) auto
  thus ?thesis
    by auto (metis frameIntAssociativity FrameStatEqSym)
qed

lemma bangActE:
  assumes "\<Psi> \<rhd> !P \<longmapsto>\<alpha> \<prec> P'"
  and     "bn \<alpha> \<sharp>* subject \<alpha>"
  and     "guarded P"
  and     "\<alpha> \<noteq> \<tau>"
  and     "bn \<alpha> \<sharp>* P"

  obtains Q where "\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q; P' \<sim> Q \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from \<open>\<Psi> \<rhd> !P \<longmapsto>\<alpha> \<prec> P'\<close> \<open>bn \<alpha> \<sharp>* subject \<alpha>\<close> \<open>\<alpha> \<noteq> \<tau>\<close> \<open>bn \<alpha> \<sharp>* P\<close>  have "\<exists>Q. \<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
  proof(nominal_induct rule: bangInduct')
    case(cAlpha \<alpha> P' p)
    then obtain Q where "\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by fastforce
    from \<open>\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q\<close> have "distinct(bn \<alpha>)" by(rule boundOutputDistinct)
    have S: "set p \<subseteq> set(bn \<alpha>) \<times> set(bn(p \<bullet> \<alpha>))" by fact
    from \<open>\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q\<close> \<open>bn(p \<bullet> \<alpha>) \<sharp>* \<alpha>\<close> \<open>bn(p \<bullet> \<alpha>) \<sharp>* P\<close> \<open>bn \<alpha> \<sharp>* subject \<alpha>\<close> \<open>distinct(bn \<alpha>)\<close>
    have "bn(p \<bullet> \<alpha>) \<sharp>* Q" by(force dest: freeFreshChainDerivative)
    with \<open>\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q\<close> \<open>bn(p \<bullet> \<alpha>) \<sharp>* \<alpha>\<close> S \<open>bn \<alpha> \<sharp>* subject \<alpha>\<close> \<open>distinct(bn \<alpha>)\<close> have "\<Psi> \<rhd> P \<longmapsto>(p \<bullet> \<alpha>) \<prec> (p \<bullet> Q)"
      by(fastforce simp add: residualAlpha)
    moreover from \<open>P' \<sim> Q \<parallel> (P \<parallel> !P)\<close> have "(p \<bullet> \<one>) \<rhd> (p \<bullet> P') \<sim> (p \<bullet> (Q \<parallel> (P \<parallel> !P)))"
      by(rule bisimClosed)
    with \<open>(bn \<alpha>) \<sharp>* P\<close> \<open>bn(p \<bullet> \<alpha>) \<sharp>* P\<close> S have "(p \<bullet> P') \<sim> (p \<bullet> Q) \<parallel> (P \<parallel> !P)"
      by(simp add: eqvts)
    ultimately show ?case by blast
  next
    case(cPar1 \<alpha> P')
    from \<open>guarded P\<close> have "P' \<parallel> !P \<sim> P' \<parallel> (P \<parallel> !P)" by(metis bangExt bisimParPresSym)
    with \<open>\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> P'\<close> show ?case by blast
  next
    case(cPar2 \<alpha> P')
    then obtain Q where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> !P" by blast
    from \<open>P' \<sim> Q \<parallel> !P\<close> have "P \<parallel> P' \<sim> Q \<parallel> (P \<parallel> !P)"
      by(metis bisimParPresSym bisimParAssoc bisimTransitive bisimParComm)
    with PTrans show ?case by blast
  next
    case cComm1
    from \<open>\<tau> \<noteq> \<tau>\<close> have False by simp
    thus ?case by simp
  next
    case cComm2
    from \<open>\<tau> \<noteq> \<tau>\<close> have False by simp
    thus ?case by simp
  next
    case(cBang \<alpha> P')
    then obtain Q where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by blast
    from \<open>P' \<sim> Q \<parallel> (P \<parallel> !P)\<close> \<open>guarded P\<close> have "P' \<sim> Q \<parallel> !P" by(metis bisimTransitive bisimParPresSym bangExt bisimSymmetric)
    with PTrans show ?case by blast
  qed
  ultimately show ?thesis by blast
qed

lemma bangTauE:
  assumes "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q" and "P' \<sim> Q \<parallel> !P"
using assms
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> P \<parallel> P\<longmapsto>\<tau> \<prec> Q; P' \<sim> Q \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from assms have "\<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
  proof(nominal_induct rule: bangTauInduct)
    case(cPar1 P')
    obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* \<Psi>" and "A\<^sub>P \<sharp>* P"
      by(rule_tac C="(\<Psi>, P)" in freshFrame) auto
    from \<open>guarded P\<close> FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guardedStatEq) auto
    with \<open>\<Psi> \<rhd> P \<longmapsto>\<tau> \<prec> P'\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>\<tau> \<prec> P'"
      by(rule_tac statEqTransition, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    hence "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> P' \<parallel> P" using FrP \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close> by(rule_tac Par1) auto
    moreover from \<open>guarded P\<close> have "P' \<parallel> !P \<sim> (P' \<parallel> P) \<parallel> (P \<parallel> !P)"
      by(metis bisimParPresSym bisimParAssoc bisimTransitive bisimParComm bangExt)
    ultimately show ?case by blast
  next
    case(cPar2 P')
    then obtain n Q where PTrans: "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q" and "P' \<sim> Q \<parallel> !P" by blast
    from \<open>P' \<sim> Q \<parallel> !P\<close> have "P \<parallel> P' \<sim> Q \<parallel> (P \<parallel> !P)"
      by(metis bisimParPresSym bisimParAssoc bisimTransitive bisimParComm)
    with PTrans show ?case by blast
  next
    case(cComm1 M N P' K xvec P'')
    obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* \<Psi>" and "A\<^sub>P \<sharp>* P" and "A\<^sub>P \<sharp>* M"
      by(rule_tac C="(\<Psi>, P, M)" in freshFrame) auto
    from \<open>guarded P\<close> FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guardedStatEq) auto
    obtain A\<^sub>P' \<Psi>\<^sub>P' where FrP': "extractFrame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>" and "A\<^sub>P' \<sharp>* \<Psi>" and "A\<^sub>P' \<sharp>* P" and "A\<^sub>P' \<sharp>* K" and "A\<^sub>P' \<sharp>* A\<^sub>P"
      by(rule_tac C="(\<Psi>, P, K, A\<^sub>P)" in freshFrame) auto
    from \<open>guarded P\<close> FrP' have "\<Psi>\<^sub>P' \<simeq> \<one>" by(drule_tac guardedStatEq) auto
    with \<open>\<Psi> \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'"
      by(rule_tac statEqTransition, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    moreover from \<open>\<Psi> \<rhd> !P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''\<close> \<open>guarded P\<close> \<open>xvec \<sharp>* P\<close> \<open>xvec \<sharp>* K\<close>
    obtain Q where PTrans: "\<Psi> \<rhd> P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q" and "P'' \<sim> Q \<parallel> !P"
      by(drule_tac bangActE) auto
    from PTrans \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q"
      by(rule_tac statEqTransition, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    moreover from \<open>\<Psi> \<turnstile> M \<leftrightarrow> K\<close> \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> \<open>\<Psi>\<^sub>P' \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>P' \<turnstile> M \<leftrightarrow> K"
      by(rule_tac statEqEnt, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    ultimately have "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)" using FrP FrP' \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close> \<open>A\<^sub>P \<sharp>* M\<close> \<open>A\<^sub>P' \<sharp>* \<Psi>\<close> \<open>A\<^sub>P' \<sharp>* P\<close> \<open>A\<^sub>P' \<sharp>* K\<close> \<open>A\<^sub>P' \<sharp>* A\<^sub>P\<close> \<open>xvec \<sharp>* P\<close>
      by(rule_tac Comm1) (assumption | simp)+
    moreover from \<open>P'' \<sim> Q \<parallel> !P\<close> \<open>guarded P\<close> have "P' \<parallel> P'' \<sim> (P' \<parallel> Q) \<parallel> (P \<parallel> !P)"
      by(metis bisimTransitive bangExt bisimParPresSym bisimParAssoc bisimSymmetric)
    hence "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> Q) \<parallel> (P \<parallel> !P))" by(rule_tac bisimResChainPres) auto
    with \<open>xvec \<sharp>* P\<close> \<open>xvec \<sharp>* \<Psi>\<close> have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)) \<parallel> (P \<parallel> !P)"
      by(force intro: bisimTransitive bisimScopeExtChainSym)
    ultimately show ?case by blast
  next
    case(cComm2 M N P' K xvec P'')
    obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* \<Psi>" and "A\<^sub>P \<sharp>* P" and "A\<^sub>P \<sharp>* M"
      by(rule_tac C="(\<Psi>, P, M)" in freshFrame) auto
    from \<open>guarded P\<close> FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guardedStatEq) auto
    obtain A\<^sub>P' \<Psi>\<^sub>P' where FrP': "extractFrame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>" and "A\<^sub>P' \<sharp>* \<Psi>" and "A\<^sub>P' \<sharp>* P" and "A\<^sub>P' \<sharp>* K" and "A\<^sub>P' \<sharp>* A\<^sub>P"
      by(rule_tac C="(\<Psi>, P, K, A\<^sub>P)" in freshFrame) auto
    from \<open>guarded P\<close> FrP' have "\<Psi>\<^sub>P' \<simeq> \<one>" by(drule_tac guardedStatEq) auto
    with \<open>\<Psi> \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
      by(rule_tac statEqTransition, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    moreover from \<open>\<Psi> \<rhd> !P \<longmapsto>K\<lparr>N\<rparr> \<prec> P''\<close> \<open>guarded P\<close>
    obtain Q where PTrans: "\<Psi> \<rhd> P \<longmapsto>K\<lparr>N\<rparr> \<prec> Q" and "P'' \<sim> Q \<parallel> !P" by(rule_tac bangActE) auto
    from PTrans \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>K\<lparr>N\<rparr> \<prec> Q"
      by(rule_tac statEqTransition, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    moreover from \<open>\<Psi> \<turnstile> M \<leftrightarrow> K\<close> \<open>\<Psi>\<^sub>P \<simeq> \<one>\<close> \<open>\<Psi>\<^sub>P' \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>P' \<turnstile> M \<leftrightarrow> K"
      by(rule_tac statEqEnt, auto) (metis Identity AssertionStatEqSym compositionSym AssertionStatEqTrans)
    ultimately have "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)" using FrP FrP' \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close> \<open>A\<^sub>P \<sharp>* M\<close> \<open>A\<^sub>P' \<sharp>* \<Psi>\<close> \<open>A\<^sub>P' \<sharp>* P\<close> \<open>A\<^sub>P' \<sharp>* K\<close> \<open>A\<^sub>P' \<sharp>* A\<^sub>P\<close> \<open>xvec \<sharp>* P\<close>
      by(rule_tac Comm2) (assumption | simp)+
    moreover from \<open>P'' \<sim> Q \<parallel> !P\<close> \<open>guarded P\<close> have "P' \<parallel> P'' \<sim> (P' \<parallel> Q) \<parallel> (P \<parallel> !P)"
      by(metis bisimTransitive bangExt bisimParPresSym bisimParAssoc bisimSymmetric)
    hence "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> Q) \<parallel> (P \<parallel> !P))" by(rule_tac bisimResChainPres) auto
    with \<open>xvec \<sharp>* P\<close> \<open>xvec \<sharp>* \<Psi>\<close> have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)) \<parallel> (P \<parallel> !P)"
      by(force intro: bisimTransitive bisimScopeExtChainSym)
    ultimately show ?case by blast
  next
    case(cBang P')
    then obtain Q where PTrans: "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by blast
    from \<open>P' \<sim> Q \<parallel> (P \<parallel> !P)\<close> \<open>guarded P\<close> have "P' \<sim> Q \<parallel> !P" by(metis bisimTransitive bisimParPresSym bangExt bisimSymmetric)
    with PTrans show ?case by blast
  qed
  ultimately show ?thesis by blast
qed

lemma tauBangI:
  fixes \<Psi> :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   P' :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> Q" and "Q \<sim> P' \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> Q; Q \<sim> P' \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from \<open>\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> P'\<close> have "\<exists>Q. \<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> Q \<and> Q \<sim> P' \<parallel> !P"
  proof(induct rule: parTauCases[where C="()"])
    case(cPar1 P' A\<^sub>P \<Psi>\<^sub>P)
    from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>\<tau> \<prec> P'\<close> have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>\<tau> \<prec> P'"
      by(rule statEqTransition) (metis Identity AssertionStatEqSym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> P' \<parallel> !P" by(rule_tac Par1) auto
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>\<tau> \<prec> P' \<parallel> !P" using \<open>guarded P\<close> by(rule Bang)
     hence "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using \<open>extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>\<close> \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close>
       by(rule_tac Par2) auto
     hence "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using \<open>guarded P\<close> by(rule Bang)
     moreover have "P \<parallel> (P' \<parallel> !P) \<sim> P' \<parallel> P \<parallel> !P"
       by(metis bisimParAssoc bisimParComm bisimTransitive bisimSymmetric bisimParPres)
     ultimately show ?case by blast
   next
    case(cPar2 P' A\<^sub>P \<Psi>\<^sub>P)
    from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>\<tau> \<prec> P'\<close> have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>\<tau> \<prec> P'"
      by(rule statEqTransition) (metis Identity AssertionStatEqSym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> P' \<parallel> !P" by(rule_tac Par1) auto
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>\<tau> \<prec> P' \<parallel> !P" using \<open>guarded P\<close> by(rule Bang)
     hence "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using \<open>extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>\<close> \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close>
       by(rule_tac Par2) auto
     hence "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using \<open>guarded P\<close> by(rule Bang)
     moreover have "P \<parallel> (P' \<parallel> !P) \<sim> P \<parallel> P' \<parallel> !P"
       by(metis bisimParAssoc bisimSymmetric)
     ultimately show ?case by blast
   next
     case(cComm1 \<Psi>\<^sub>P' M N P' A\<^sub>P \<Psi>\<^sub>P K xvec P'' A\<^sub>P')
     from \<open>extractFrame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>\<close> \<open>guarded P\<close> have "\<Psi>\<^sub>P' \<simeq> \<one>" by(blast dest: guardedStatEq)
     with \<open>\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'\<close> have "\<Psi> \<otimes> \<one> \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'"
       by(rule_tac statEqTransition, auto) (metis compositionSym AssertionStatEqSym)
     moreover note \<open>extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>\<close>
     moreover from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''\<close> have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''"
       by(rule statEqTransition) (metis Identity AssertionStatEqSym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> (P'' \<parallel> !P)" using \<open>xvec \<sharp>* P\<close> by(force intro: Par1)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> (P'' \<parallel> !P)" using \<open>guarded P\<close> by(rule Bang)
     moreover from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>P' \<turnstile> M \<leftrightarrow> K\<close> \<open>\<Psi>\<^sub>P' \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<one> \<turnstile> M \<leftrightarrow> K"
       by(rule_tac statEqEnt, auto) (metis compositionSym AssertionStatEqSym)
     ultimately have "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))"
       using \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close> \<open>A\<^sub>P \<sharp>* M\<close> \<open>A\<^sub>P \<sharp>* A\<^sub>P'\<close> \<open>A\<^sub>P' \<sharp>* \<Psi>\<close> \<open>A\<^sub>P' \<sharp>* P\<close> \<open>A\<^sub>P' \<sharp>* K\<close> \<open>xvec \<sharp>* P\<close>
       by(force intro: Comm1)
     hence "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))" using \<open>guarded P\<close> by(rule Bang)
     moreover have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P)) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P"
     proof -
       have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P)) \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P)"
         by(force intro: bisimResChainPres bisimParAssoc[THEN bisimSymmetric])
       moreover have "\<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P" using \<open>xvec \<sharp>* P\<close>
         by(rule_tac bisimScopeExtChainSym) auto
       ultimately show ?thesis by(rule bisimTransitive)
     qed
     ultimately show ?case by blast
   next
     case(cComm2 \<Psi>\<^sub>P' M xvec N P' A\<^sub>P \<Psi>\<^sub>P K P'' A\<^sub>P')
     from \<open>extractFrame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>\<close> \<open>guarded P\<close> have "\<Psi>\<^sub>P' \<simeq> \<one>" by(blast dest: guardedStatEq)
     with \<open>\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle>\<prec> P'\<close> have "\<Psi> \<otimes> \<one> \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
       by(rule_tac statEqTransition, auto) (metis compositionSym AssertionStatEqSym)
     moreover note \<open>extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>\<close>
     moreover from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>K\<lparr>N\<rparr> \<prec> P''\<close> have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>K\<lparr>N\<rparr> \<prec> P''"
       by(rule statEqTransition) (metis Identity AssertionStatEqSym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>K\<lparr>N\<rparr> \<prec> (P'' \<parallel> !P)" by(force intro: Par1)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>K\<lparr>N\<rparr> \<prec> (P'' \<parallel> !P)" using \<open>guarded P\<close> by(rule Bang)
     moreover from \<open>\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>P' \<turnstile> M \<leftrightarrow> K\<close> \<open>\<Psi>\<^sub>P' \<simeq> \<one>\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<one> \<turnstile> M \<leftrightarrow> K"
       by(rule_tac statEqEnt, auto) (metis compositionSym AssertionStatEqSym)
     ultimately have "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))"
       using \<open>A\<^sub>P \<sharp>* \<Psi>\<close> \<open>A\<^sub>P \<sharp>* P\<close> \<open>A\<^sub>P \<sharp>* M\<close> \<open>A\<^sub>P \<sharp>* A\<^sub>P'\<close> \<open>A\<^sub>P' \<sharp>* \<Psi>\<close> \<open>A\<^sub>P' \<sharp>* P\<close> \<open>A\<^sub>P' \<sharp>* K\<close> \<open>xvec \<sharp>* P\<close>
       by(force intro: Comm2)
     hence "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))" using \<open>guarded P\<close> by(rule Bang)
     moreover have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P)) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P"
     proof -
       have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P)) \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P)"
         by(force intro: bisimResChainPres bisimParAssoc[THEN bisimSymmetric])
       moreover have "\<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P" using \<open>xvec \<sharp>* P\<close>
         by(rule_tac bisimScopeExtChainSym) auto
       ultimately show ?thesis by(rule bisimTransitive)
     qed
     ultimately show ?case by blast
   qed
   ultimately show ?thesis by blast
qed

lemma tauChainBangI:
  fixes \<Psi> :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   P' :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q; \<Psi> \<rhd> Q \<sim> P' \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from \<open>\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'\<close> have "\<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
  proof(induct x1=="P \<parallel> P" P' rule: tauChainInduct)
    case TauBase
    have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> !P" by simp
    moreover have "\<Psi> \<rhd> !P \<sim> (P \<parallel> P) \<parallel> !P" using \<open>guarded P\<close>
      by(metis bisimParAssoc bisimTransitive bisimParPresSym bangExt bisimParComm)
    ultimately show ?case by blast
  next
    case(TauStep R' R'')
    then obtain Q where PChain: "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> R' \<parallel> !P" by auto
    from \<open>\<Psi> \<rhd> R' \<longmapsto>\<tau> \<prec> R''\<close> have "\<Psi> \<otimes> \<one> \<rhd> R' \<longmapsto>\<tau> \<prec> R''" by(rule statEqTransition) (metis Identity AssertionStatEqSym)
    hence "\<Psi> \<rhd> R' \<parallel> !P \<longmapsto>\<tau> \<prec> R'' \<parallel> !P" by(rule_tac Par1) auto
    with \<open>\<Psi> \<rhd> Q \<sim> R' \<parallel> !P\<close> obtain Q' where QTrans: "\<Psi> \<rhd> Q \<longmapsto>\<tau> \<prec> Q'" and "\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P"
      by(force dest: bisimE(2) simE)
    from PChain QTrans have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" by(auto dest: tauActTauChain)
    thus ?case using \<open>\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P\<close> by blast
  qed
  ultimately show ?thesis by blast
qed

lemma weakBisimBangPresAux:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"
  and     "guarded P"
  and     "guarded Q"

  shows   "\<Psi> \<rhd> R \<parallel> !P \<approx> R \<parallel> !Q"
proof -
  let ?X = "{(\<Psi>, R \<parallel> !P, R \<parallel> !Q) | \<Psi> R P Q. guarded P \<and> guarded Q \<and> \<Psi> \<rhd> P \<approx> Q}"
  let ?Y = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>R S. \<Psi> \<rhd> P \<approx> R \<and> (\<Psi>, R, S) \<in> ?X \<and> \<Psi> \<rhd> S \<sim> Q}"

  from assms have "(\<Psi>, R \<parallel> !P, R \<parallel> !Q) \<in> ?X" by auto
  moreover have "eqvt ?X"
    by(fastforce simp add: eqvt_def intro: weakBisimClosed)
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveCoinduct2)
    case(cStatImp \<Psi> P Q)
    thus ?case by(force dest: weakBisimE(3) simp add: weakStatImp_def)
  next
    case(cSim \<Psi> P Q)
    moreover {
      fix \<Psi> P Q R
      assume "\<Psi> \<rhd> P \<approx> Q"
      moreover have "eqvt ?Y"
        apply(auto simp add: eqvt_def)
        apply(rule_tac x="p \<bullet> (Ra \<parallel> !P)" in exI, auto)
        apply(fastforce dest: weakBisimClosed simp add: eqvts)
        apply(rule_tac x="(p \<bullet> Ra) \<parallel> !(p \<bullet> Q)" in exI, auto)
        apply(rule_tac x="p \<bullet> Ra" in exI)
        apply(rule_tac x="p \<bullet> P" in exI, auto)
        apply(rule_tac x="p \<bullet> Q" in exI, auto)
        apply(blast intro: weakBisimClosed)
        by(fastforce dest: bisimClosed simp add: eqvts)
      moreover assume "guarded P" and "guarded Q"
      moreover note weakBisimClosed bisimClosed weakBisimE(3) bisimE(3) weakBisimE(2) weakBisimE(4) bisimE(4) statEqWeakBisim statEqBisim weakBisimTransitive bisimTransitive weakBisimParAssoc[THEN weakBisimE(4)] bisimParAssoc[THEN bisimE(4)] weakBisimParPres
      moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<approx> Q \<Longrightarrow> \<Psi> \<rhd> P \<parallel> P \<approx> Q \<parallel> Q"
        by(metis weakBisimParPres weakBisimParComm weakBisimE(4) weakBisimTransitive)
      moreover note bisimParPresSym
      moreover have "bisim \<subseteq> weakBisim" by(auto dest: strongBisimWeakBisim)
      moreover have "\<And>\<Psi> \<Psi>\<^sub>R P Q R A\<^sub>R. \<lbrakk>\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q; extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
        by(metis weakBisimParComm weakBisimTransitive weakBisimParPresAux)
      moreover note weakBisimResChainPres bisimResChainPres weakBisimScopeExtChainSym bisimScopeExtChainSym
      moreover have "\<And>\<Psi> P R S Q. \<lbrakk>\<Psi> \<rhd> P \<approx> R; (\<Psi>, R, S) \<in> ?Y; \<Psi> \<rhd> S \<sim> Q\<rbrakk> \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Y"
        by(blast dest: weakBisimTransitive bisimTransitive)
      moreover have "\<And>\<Psi> P Q R. \<lbrakk>\<Psi> \<rhd> P \<approx> Q; guarded P; guarded Q\<rbrakk> \<Longrightarrow> (\<Psi>, R \<parallel> !P, R \<parallel> !Q) \<in> ?Y"
        by(blast intro: bisimReflexive weakBisimReflexive)
      moreover from bangActE have "\<And>\<Psi> P \<alpha> P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<alpha> \<prec> P'; bn \<alpha> \<sharp>* P; guarded P; \<alpha> \<noteq> \<tau>; bn \<alpha> \<sharp>* subject \<alpha>\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
        by blast
      moreover from bangTauE have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
        by blast
      moreover from tauChainBangI have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
        by blast
      ultimately have  "\<Psi> \<rhd> R \<parallel> !P \<leadsto><?Y> R \<parallel> !Q"
        by(rule_tac weakSimBangPres)
    }
    ultimately show ?case by blast
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimBangPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"
  and     "guarded P"
  and     "guarded Q"

  shows   "\<Psi> \<rhd> !P \<approx> !Q"
proof -
  from assms have "\<Psi> \<rhd> \<zero> \<parallel> !P \<approx> \<zero> \<parallel> !Q" by(rule weakBisimBangPresAux)
  thus ?thesis
    by(metis weakBisimParNil weakBisimParComm weakBisimTransitive weakBisimE(4))
qed

end

end


theory DenotationalEquivalences
imports "Denotational-PropsUpd" "Denotational-Props"
begin

lemma disjoint_join_is_update:
  assumes "fdom \<rho>1 = d1"
  assumes "fdom \<rho>2 = d2"
  assumes "d1 \<inter> d2 = {}"
  shows "\<rho>1\<^bsub>[d1 \<union> d2]\<^esub> \<squnion> \<rho>2\<^bsub>[d1 \<union> d2]\<^esub> = \<rho>1 f++ \<rho>2"
proof-
  have disjoint: "fdom \<rho>1 \<inter> fdom \<rho>2 = {}" using assms by auto

  have compat[simp]: "compatible (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>) (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
  proof (rule compatible_fmapI)
    show "fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>) = fdom (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
      by simp
    fix x
    assume "x \<in> fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
    hence "(x \<in> fdom \<rho>1 \<and> x \<notin> fdom \<rho>2) \<or> (x \<in> fdom \<rho>2 \<and> x \<notin> fdom \<rho>1)" using disjoint by auto
    thus "compatible (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x) (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x)"
      by auto
  qed

  have "\<rho>1 f++ \<rho>2 = \<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>"
  proof
    show "fdom (\<rho>1 f++ \<rho>2) = fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
      by simp
  next
    fix x
    assume "x \<in> fdom (\<rho>1 f++ \<rho>2)"
    hence "(x \<in> fdom \<rho>1 \<and> x \<notin> fdom \<rho>2) \<or> (x \<in> fdom \<rho>2 \<and> x \<notin> fdom \<rho>1)" using disjoint by auto
    thus "\<rho>1 f++ \<rho>2 f! x = \<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x"
      by auto
  qed
  thus ?thesis using assms by simp
qed

theorem heap_update_join:
  assumes disjoint: "fdom \<rho> \<inter> heapVars \<Gamma> = {}"
  assumes exp_eq: "\<And> e \<rho>. e \<in> snd ` set \<Gamma> \<Longrightarrow> DenotationalUpd.ESem e \<rho> = Denotational.ESem e \<rho>"
  shows "DenotationalUpd.HSem \<Gamma> \<rho> = Denotational.HSem \<Gamma> \<rho>"
proof-
  have cond: "HSem_cond'' \<Gamma> \<rho>"
    by (rule disjoint_is_HSem_cond[OF disjoint])

  have heapToEnv_eq: "\<And> \<rho>. heapToEnv \<Gamma> (\<lambda>e. DenotationalUpd.ESem e \<rho>) = heapToEnv \<Gamma> (\<lambda>e. Denotational.ESem e \<rho>)"
    by (rule heapToEnv_cong[OF refl exp_eq])

  show ?thesis
    unfolding "Denotational-PropsUpd.HSem_def'" "Denotational.HSem_def'"[OF cond]
    apply (simp add: bottom_of_fjc to_bot_fmap_def)
    apply (rule fix_on_cong[OF fix_on_cond_HSem])
    apply simp
    apply (drule sym)
    apply simp
    apply (subst heapToEnv_eq)
    apply (rule disjoint_join_is_update[OF refl _ disjoint, symmetric])
    apply simp
    done
qed

theorem HSem_join_update:
  "DenotationalUpd.ESem e \<rho> = Denotational.ESem e \<rho>" and "\<And> e. e \<in> snd ` set (asToHeap as) \<Longrightarrow> DenotationalUpd.ESem e \<rho> = Denotational.ESem e \<rho>"
proof(nominal_induct e and  avoiding: \<rho>  rule:exp_assn.strong_induct)
case (Let as e \<rho>)
  have "fdom \<rho> \<inter> heapVars (asToHeap as) = {}"
    by (metis Let(1) disjoint_iff_not_equal sharp_star_Env)
  hence "DenotationalUpd.HSem (asToHeap as) \<rho> = Denotational.HSem (asToHeap as) \<rho>"
    by (rule heap_update_join[OF _ Let(2)])
  thus ?case using Let(1,3) by simp
qed auto
end