section "Executable Sorts"

theory SortsExe
  imports Sorts
begin

type_synonym exeosig = "(class \<times> class) list \<times> (name \<times> (class \<times> sort list) list) list"

abbreviation (input) "execlasses \<equiv> fst"
abbreviation (input) "exetcsigs \<equiv> snd"

(* Eliminate fully? *)
abbreviation alist_conds :: "('k::linorder \<times> 'v) list \<Rightarrow> bool" where
  "alist_conds al \<equiv> distinct (map fst al)"

(* This is not executable *)
definition exe_ars_conds :: "(name \<times> (class \<times> sort list) list) list \<Rightarrow> bool" where
  "exe_ars_conds arss \<longleftrightarrow> alist_conds arss \<and> (\<forall>ars \<in> snd ` set arss . alist_conds ars)"

fun exe_ars_conds' :: "(('k1::linorder) \<times> (('k2::linorder) \<times> 's list) list) list \<Rightarrow> bool" where
  "exe_ars_conds' arss \<longleftrightarrow> alist_conds arss \<and> (\<forall>ars \<in> snd ` set arss . alist_conds ars)"

definition exe_class_conds :: "(class \<times> class) list \<Rightarrow> bool" where
  "exe_class_conds cs \<equiv> distinct cs"

definition exe_osig_conds :: "exeosig \<Rightarrow> bool" where
  "exe_osig_conds a \<equiv> exe_class_conds (execlasses a) \<and> exe_ars_conds (exetcsigs a)"

fun translate_ars :: "(name \<times> (class \<times> sort list) list) list \<Rightarrow> name \<rightharpoonup> (class \<rightharpoonup> sort list)" where
  "translate_ars ars = map_of (map (apsnd map_of) ars)"

abbreviation "illformed_osig \<equiv> ({}, Map.empty(STR ''A'' \<mapsto> Map.empty(STR ''A'' \<mapsto> [{STR ''A''}])))"

lemma illformed_osig_not_wf_osig: "\<not> wf_osig illformed_osig"
  by (auto simp add: coregular_tcsigs_def complete_tcsigs_def consistent_length_tcsigs_def
      all_normalized_and_ex_tcsigs_def sort_ex_def wf_sort_def)

(* I should probably do this with an option return type instead... *)
fun translate_osig :: "exeosig \<Rightarrow> osig" where
  "translate_osig (cs, arss) = (if exe_osig_conds (cs, arss)
    then (set cs, translate_ars arss)
    else illformed_osig)"

definition "exe_consistent_length_tcsigs arss \<equiv> (\<forall>ars \<in> snd ` set arss .
  \<forall>ss\<^sub>1 \<in> snd ` set ars. \<forall>ss\<^sub>2 \<in> snd ` set ars. length ss\<^sub>1 = length ss\<^sub>2)"

lemma in_alist_imp_in_map_of: "distinct (map fst arss)
  \<Longrightarrow> (name, ars) \<in> set arss \<Longrightarrow> translate_ars arss name = Some (map_of ars)"
  by (induction arss) (auto simp add: rev_image_eqI)

lemma "exe_ars_conds arss \<Longrightarrow> \<exists>name . map_of (map (apsnd map_of) arss) name = Some ars
  \<Longrightarrow> \<exists>name arsl . (name, arsl) \<in> set arss \<and> map_of arsl = ars"
  by (force simp add: exe_ars_conds_def)

lemma "exe_ars_conds arss
  \<Longrightarrow> (name, arsl) \<in> set arss \<and> map_of arsl = ars
  \<Longrightarrow> map_of (map (apsnd map_of) arss) name = Some ars"
  by (force simp add: exe_ars_conds_def)

lemma consistent_length_tcsigs_imp_exe_consistent_length_tcsigs:
  "exe_ars_conds arss \<Longrightarrow> consistent_length_tcsigs (translate_ars arss)
  \<Longrightarrow> exe_consistent_length_tcsigs arss"
  unfolding consistent_length_tcsigs_def exe_consistent_length_tcsigs_def
  apply (clarsimp simp add: exe_ars_conds_def)
  by (metis in_alist_imp_in_map_of map_of_is_SomeI ranI snd_conv translate_ars.simps)

lemma exe_consistent_length_tcsigs_imp_consistent_length_tcsigs:
  assumes "exe_ars_conds arss" "exe_consistent_length_tcsigs arss"
  shows "consistent_length_tcsigs (translate_ars arss)"
proof-
  {
    fix ars ss\<^sub>1 ss\<^sub>2
    assume p: "ars \<in> ran (map_of (map (apsnd map_of) arss))" "ss\<^sub>1 \<in> ran ars" "ss\<^sub>2 \<in> ran ars"
    from p(1) obtain name where "map_of (map (apsnd map_of) arss) name = Some ars"
      by (meson in_range_if_ex_key)
    from this obtain arsl where "(name, arsl) \<in> set arss" "map_of arsl = ars"
      using assms(1) by (auto simp add: exe_ars_conds_def)
    from this obtain c1 c2 where "ars c1 = Some ss\<^sub>1" "ars c2 = Some ss\<^sub>2"
      by (metis in_range_if_ex_key p(2) p(3))
    hence "(c1, ss\<^sub>1) \<in> set arsl" "(c2, ss\<^sub>2) \<in> set arsl"
      by (simp_all add: \<open>map_of arsl = ars\<close> map_of_SomeD)
    hence "length ss\<^sub>1 = length ss\<^sub>2"
      using assms(2) \<open>(name, arsl) \<in> set arss\<close>
      by (fastforce simp add: exe_consistent_length_tcsigs_def)
  }
  note 1 = this
  show ?thesis
    by (simp add: consistent_length_tcsigs_def exe_consistent_length_tcsigs_def) (use 1 in blast)
qed

lemma consistent_length_tcsigs_iff_exe_consistent_length_tcsigs:
  "exe_ars_conds arss \<Longrightarrow>
    consistent_length_tcsigs (translate_ars arss) \<longleftrightarrow> exe_consistent_length_tcsigs arss"
  using consistent_length_tcsigs_imp_exe_consistent_length_tcsigs
    exe_consistent_length_tcsigs_imp_consistent_length_tcsigs by blast

(* Do I even have to translate the relation? *)
definition "exe_complete_tcsigs cs arss
 \<equiv> (\<forall>ars \<in> snd ` set arss .
  \<forall>(c\<^sub>1, c\<^sub>2) \<in> set cs . c\<^sub>1\<in>fst ` set ars \<longrightarrow> c\<^sub>2\<in>fst ` set ars)"

lemma exe_complete_tcsigs_imp_complete_tcsigs:
  assumes "exe_ars_conds arss" "exe_complete_tcsigs cs arss"
  shows "complete_tcsigs (set cs) (translate_ars arss)"
proof-
  {
    fix ars a b y
    assume p: "ars \<in> ran (map_of (map (apsnd map_of) arss))"
       "(a, b) \<in> set cs" "ars a = Some y"

    from p(1) obtain name where "map_of (map (apsnd map_of) arss) name = Some ars"
      by (meson in_range_if_ex_key)
    from this obtain arsl where "(name, arsl) \<in> set arss" "map_of arsl = ars"
      using assms(1) by (auto simp add: exe_ars_conds_def)
    hence "(a, y) \<in> set arsl"
      by (simp add: map_of_SomeD p(3))
    hence"\<exists>y. ars b = Some y"
      using assms(2) \<open>(name, arsl) \<in> set arss\<close>
      apply (clarsimp simp add: exe_complete_tcsigs_def)
      by (metis (no_types, lifting) \<open>map_of arsl = ars\<close> case_prodD domD domI dom_map_of_conv_image_fst
          p(2) p(3) snd_conv)
  }
  note 1 = this
  show ?thesis
    by (simp add: complete_tcsigs_def exe_complete_tcsigs_def) (use 1 in blast)
qed

lemma complete_tcsigs_imp_exe_complete_tcsigs: "exe_ars_conds arss \<Longrightarrow>
    complete_tcsigs (set cs) (translate_ars arss) \<Longrightarrow> exe_complete_tcsigs cs arss"
  unfolding complete_tcsigs_def exe_complete_tcsigs_def exe_ars_conds_def
  by (metis (mono_tags, lifting) case_prod_unfold dom_map_of_conv_image_fst in_alist_imp_in_map_of
      in_range_if_ex_key map_of_SomeD ran_distinct)

lemma exe_complete_tcsigs_iff_complete_tcsigs:
  "exe_ars_conds arss \<Longrightarrow>
    complete_tcsigs (set cs) (translate_ars arss) \<longleftrightarrow> exe_complete_tcsigs cs arss"
  using exe_complete_tcsigs_imp_complete_tcsigs complete_tcsigs_imp_exe_complete_tcsigs
  by blast

definition "exe_coregular_tcsigs (cs :: (class \<times> class) list) arss
  \<equiv> (\<forall>ars \<in> snd ` set arss .
  \<forall>c\<^sub>1 \<in> fst ` set ars. \<forall>c\<^sub>2 \<in> fst ` set ars.
    (class_leq (set cs) c\<^sub>1 c\<^sub>2 \<longrightarrow>
      list_all2 (sort_leq (set cs)) (the (lookup (\<lambda>x. x=c\<^sub>1) ars)) (the (lookup (\<lambda>x. x=c\<^sub>2) ars))))"

lemma exe_coregular_tcsigs_imp_coregular_tcsigs:
  assumes "exe_ars_conds arss" "exe_coregular_tcsigs cs arss"
  shows "coregular_tcsigs (set cs) (translate_ars arss)"
proof-
  {
    fix ars c\<^sub>1 c\<^sub>2 ss1 ss2
    assume p: "ars \<in> ran (map_of (map (apsnd map_of) arss))" "ars c\<^sub>1 = Some ss1" "ars c\<^sub>2 = Some ss2"
      "class_leq (set cs) c\<^sub>1 c\<^sub>2"
    from p(1) obtain name where "map_of (map (apsnd map_of) arss) name = Some ars"
      by (meson in_range_if_ex_key)
    from this obtain arsl where "(name, arsl) \<in> set arss" "map_of arsl = ars"
      using assms(1) by (auto simp add: exe_ars_conds_def)
    from this obtain c1 c2 where "ars c1 = Some ss1" "ars c2 = Some ss2" "class_leq (set cs) c1 c2"
      using p(2) p(3) p(4) by blast
    hence "(c1, ss1) \<in> set arsl" "(c2, ss2) \<in> set arsl"
      by (simp_all add: \<open>map_of arsl = ars\<close> map_of_SomeD)
    hence "lookup (\<lambda>x. x=c1) arsl = Some ss1" "lookup (\<lambda>x. x=c2) arsl = Some ss2"
      by (metis \<open>(name, arsl) \<in> set arss\<close> assms(1) exe_ars_conds_def
          image_eqI lookup_present_eq_key snd_conv)+
    hence "list_all2 (sort_leq (set cs)) ss1 ss2"
      using assms(2) \<open>(name, arsl) \<in> set arss\<close> \<open>(c1, ss1) \<in> set arsl\<close> \<open>(c2, ss2) \<in> set arsl\<close>
        \<open>class_leq (set cs) c1 c2\<close>
      by (fastforce simp add: exe_coregular_tcsigs_def)
  }
  note 1 = this
  show ?thesis
    by (auto simp add: coregular_tcsigs_def exe_coregular_tcsigs_def) (use 1 in blast)

qed

lemma coregular_tcsigs_imp_exe_coregular_tcsigs:
  assumes "exe_ars_conds arss" "coregular_tcsigs (set cs) (translate_ars arss)"
  shows "exe_coregular_tcsigs cs arss"
proof-
  {
    fix name ars c1 ss1 c2 ss2
    assume p: "(name, ars) \<in> set arss" "(c1, ss1) \<in> set ars" "(c2, ss2) \<in> set ars"
      "class_leq (set cs) c1 c2"

    have s1: "(lookup (\<lambda>x. x = c1) ars) = Some ss1"
      using assms(1) lookup_present_eq_key p(1) p(2) by (force simp add: exe_ars_conds_def)
    have s2: "(lookup (\<lambda>x. x = c2) ars) = Some ss2"
      using assms(1) lookup_present_eq_key p(1) p(3) by (force simp add: exe_ars_conds_def)
    have "list_all2 (sort_leq (set cs)) (the (lookup (\<lambda>x. x = c1) ars)) (the (lookup (\<lambda>x. x = c2) ars))"
      using assms apply (simp add: coregular_tcsigs_def s1 s2 exe_ars_conds_def)
      by (metis domIff in_alist_imp_in_map_of map_of_is_SomeI option.distinct(1) option.sel
          p(1) p(2) p(3) p(4) ranI snd_conv translate_ars.simps)
  }
  note 1 = this
  show ?thesis
    by (auto simp add: coregular_tcsigs_def exe_coregular_tcsigs_def) (use 1 in blast)
qed

lemma coregular_tcsigs_iff_exe_coregular_tcsigs:
  "exe_ars_conds arss \<Longrightarrow> coregular_tcsigs (set cs) (translate_ars arss) \<longleftrightarrow> exe_coregular_tcsigs cs arss"
  using coregular_tcsigs_imp_exe_coregular_tcsigs exe_coregular_tcsigs_imp_coregular_tcsigs by blast

lemma "wf_subclass sub \<Longrightarrow> Field sub = Domain sub"
  using refl_on_def by fastforce

definition [simp]: "exefield rel = List.union (map fst rel) (map snd rel)"
lemma Field_set_code: "Field (set rel) = set (exefield rel)"
  by (induction rel) fastforce+

lemma class_ex_rec: "finite r \<Longrightarrow> class_ex (insert (a,b) r) c = (a=c \<or> b=c \<or> class_ex r c)"
  by (induction r rule: finite_induct) (auto simp add: class_ex_def)

definition [simp]: "execlass_ex rel c = List.member (exefield rel) c"
lemma execlass_ex_code: "class_ex (set rel) c = execlass_ex rel c"
  by (metis Field_set_code class_ex_def execlass_ex_def in_set_member)

definition [simp]: "exesort_ex rel S = (\<forall>x\<in>S . (List.member (exefield rel) x))"
lemma sort_ex_code: "sort_ex (set rel) S = exesort_ex rel S"
  by (simp add: execlass_ex_code sort_ex_class_ex)

definition [simp]: "execlass_les cs c1 c2 = (List.member cs (c1,c2) \<and> \<not> List.member cs (c2,c1))"
lemma execlass_les_code: "class_les (set cs) c1 c2 = execlass_les cs c1 c2"
  by (simp add: class_leq_def class_les_def member_def)

definition [simp]: "exenormalize_sort cs (s::sort)
  = {c \<in> s . \<not> (\<exists>c' \<in> s . execlass_les cs c' c)}"
definition [simp]: "exenormalized_sort cs s \<equiv> (exenormalize_sort cs s) = s"

lemma normalize_sort_code[code]: "normalize_sort (set cs) s = exenormalize_sort cs s"
  by (auto simp add: normalize_sort_def List.member_def list_ex_iff class_leq_def class_les_def)

lemma normalized_sort_code[code]: "normalized_sort (set cs) s = exenormalized_sort cs s"
  using exenormalized_sort_def normalize_sort_code by presburger

definition [simp]: "exewf_sort sub S \<equiv> exenormalized_sort sub S \<and> exesort_ex sub S"
lemma wf_sort_code:
  assumes "exe_class_conds sub"
  shows "wf_sort (set sub) S = exewf_sort sub S"
  using normalized_sort_code sort_ex_code assms
  by (simp add: sort_ex_code wf_sort_def)

declare exewf_sort_def[code del]
lemma [code]: "exewf_sort sub S \<equiv> (S = {} \<or> exenormalized_sort sub S \<and> exesort_ex sub S)"
  by simp (smt ball_empty bot_set_def empty_Collect_eq)

definition "exe_all_normalized_and_ex_tcsigs cs arss
 \<equiv> (\<forall>ars \<in> snd ` set arss . \<forall>ss \<in> snd ` set ars . \<forall>s \<in> set ss. exewf_sort cs s)"

lemma all_normalized_and_ex_tcsigs_imp_exe_all_normalized_and_ex_tcsigs:
  assumes "exe_ars_conds arss" "all_normalized_and_ex_tcsigs (set cs) (translate_ars arss)"
  shows "exe_all_normalized_and_ex_tcsigs cs arss"
proof-
  have ac: "alist_conds arss"
    using assms(1) exe_ars_conds_def by blast
  {
    fix s ars
    assume a1: "(s, ars) \<in> set arss"
    fix c Ss
    assume a2: "(c,Ss) \<in> set ars"
    fix S
    assume a3: "S \<in> set Ss"

    have "map_of ars \<in> ran (map_of (map (apsnd map_of) arss))"
      using ac a1 by (metis  in_alist_imp_in_map_of ranI translate_ars.simps)
    moreover have "Ss \<in> ran (map_of ars)"
      using a1 a2 assms(1) by (metis exe_ars_conds_def map_of_is_SomeI ranI ran_distinct)
    ultimately have "wf_sort (set cs) S"
      using assms(2) a1 a2 a3 by (auto simp add: all_normalized_and_ex_tcsigs_def )
  }
  thus ?thesis
    using normalize_sort_code wf_sort_def
    by (clarsimp simp add: all_normalized_and_ex_tcsigs_def exe_all_normalized_and_ex_tcsigs_def
      exe_ars_conds_def wf_sort_def wf_sort_code normalize_sort_def sort_ex_code)
qed

lemma exe_all_normalized_and_ex_tcsigs_imp_all_normalized_and_ex_tcsigs:
  assumes "exe_ars_conds arss" "exe_all_normalized_and_ex_tcsigs cs arss"
  shows "all_normalized_and_ex_tcsigs (set cs) (translate_ars arss)"
proof-
  {
    fix ars ss s
    assume p: "ars \<in> ran (map_of (map (apsnd map_of) arss))"
      "ss \<in> ran ars" "s \<in> set ss"

    from p(1) obtain name where "map_of (map (apsnd map_of) arss) name = Some ars"
      by (meson in_range_if_ex_key)
    from this obtain arsl where "(name, arsl) \<in> set arss" "map_of arsl = ars"
      using assms(1) by (auto simp add: exe_ars_conds_def)
    from this obtain c where c: "ars c = Some ss"
      using in_range_if_ex_key p(2) by force
    have "exewf_sort cs s"
      by (metis (no_types, opaque_lifting) \<open>(name, arsl) \<in> set arss\<close> \<open>map_of arsl = ars\<close> assms(1) assms(2)
          exe_all_normalized_and_ex_tcsigs_def exe_ars_conds_def image_iff p(2) p(3) ran_distinct snd_conv)
    hence "wf_sort (set cs) s"
      by (simp add: normalize_sort_code sort_ex_code wf_sort_def)
  }
  note 1 = this
  show ?thesis
    using 1 by (clarsimp simp add: wf_sort_def all_normalized_and_ex_tcsigs_def
        exe_all_normalized_and_ex_tcsigs_def)
qed

lemma all_normalized_and_ex_tcsigs_iff_exe_all_normalized_and_ex_tcsigs:
  "exe_ars_conds arss \<Longrightarrow> all_normalized_and_ex_tcsigs (set cs) (translate_ars arss)
    \<longleftrightarrow> exe_all_normalized_and_ex_tcsigs cs arss"
  using all_normalized_and_ex_tcsigs_imp_exe_all_normalized_and_ex_tcsigs exe_all_normalized_and_ex_tcsigs_imp_all_normalized_and_ex_tcsigs by blast

definition [simp]: "exe_wf_tcsigs (cs :: (class \<times> class) list) arss \<equiv>
    exe_coregular_tcsigs cs arss
  \<and> exe_complete_tcsigs cs arss
  \<and> exe_consistent_length_tcsigs arss
  \<and> exe_all_normalized_and_ex_tcsigs cs arss"

lemma wf_tcsigs_iff_exe_wf_tcsigs:
  "exe_ars_conds arss \<Longrightarrow> wf_tcsigs (set cs) (translate_ars arss) \<longleftrightarrow> exe_wf_tcsigs cs arss"
  using all_normalized_and_ex_tcsigs_iff_exe_all_normalized_and_ex_tcsigs
    consistent_length_tcsigs_imp_exe_consistent_length_tcsigs
    coregular_tcsigs_iff_exe_coregular_tcsigs exe_complete_tcsigs_iff_complete_tcsigs
    exe_consistent_length_tcsigs_imp_consistent_length_tcsigs exe_wf_tcsigs_def wf_tcsigs_def
  by blast

fun exe_antisym :: "('a \<times> 'a) list \<Rightarrow> bool" where
  "exe_antisym [] \<longleftrightarrow> True"
| "exe_antisym ((x,y)#r) \<longleftrightarrow> ((y,x)\<in>set r \<longrightarrow> x=y) \<and> exe_antisym r"

lemma exe_antisym_imp_antisym: "exe_antisym l \<Longrightarrow> antisym (set l)"
  by (induction l) (auto simp add: antisym_def)

lemma antisym_imp_exe_antisym: "antisym (set l) \<Longrightarrow> exe_antisym l"
proof (induction l)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    by (simp add: antisym_def) (metis exe_antisym.simps(2) surj_pair)
qed

lemma antisym_iff_exe_antisym: "antisym (set l) = exe_antisym l"
  using antisym_imp_exe_antisym exe_antisym_imp_antisym by blast

definition "exe_wf_subclass cs = (trans (set cs) \<and> exe_antisym cs \<and> Refl (set cs))"

lemma wf_classes_iff_exe_wf_classes: "wf_subclass (set cs) \<longleftrightarrow> exe_wf_subclass cs"
  by (simp add: antisym_iff_exe_antisym exe_wf_subclass_def)

definition [simp]: "exe_wf_osig oss \<equiv> exe_wf_subclass (execlasses oss)
  \<and> exe_wf_tcsigs (execlasses oss) (exetcsigs oss) \<and> exe_osig_conds oss"

lemma exe_wf_osig_imp_wf_osig: "exe_wf_osig oss \<Longrightarrow> wf_osig (translate_osig oss)"
  using exe_coregular_tcsigs_imp_coregular_tcsigs exe_complete_tcsigs_imp_complete_tcsigs
    exe_complete_tcsigs_imp_complete_tcsigs exe_all_normalized_and_ex_tcsigs_imp_all_normalized_and_ex_tcsigs
    exe_consistent_length_tcsigs_imp_consistent_length_tcsigs
  by (cases oss) (auto simp add: exe_wf_subclass_def exe_antisym_imp_antisym  exe_osig_conds_def)

lemma classes_translate: "exe_osig_conds oss \<Longrightarrow> subclass (translate_osig oss) = set (execlasses oss)"
  by (cases oss) simp_all

lemma tcsigs_translate: "exe_osig_conds oss
  \<Longrightarrow> tcsigs (translate_osig oss) = translate_ars (exetcsigs oss)"
  by (cases oss) simp_all

lemma wf_osig_translate_imp_exe_osig_conds:
  "wf_osig (translate_osig oss) \<Longrightarrow> exe_osig_conds oss"
  using illformed_osig_not_wf_osig by (metis translate_osig.elims)

lemma wf_osig_imp_exe_wf_osig:
  assumes "wf_osig (translate_osig oss)" shows "exe_wf_osig oss"
  apply (cases "translate_osig oss")
  using classes_translate tcsigs_translate assms wf_osig_translate_imp_exe_osig_conds
  by (metis (full_types) exe_osig_conds_def exe_wf_osig_def subclass.simps tcsigs.simps
      wf_classes_iff_exe_wf_classes wf_osig.simps wf_tcsigs_iff_exe_wf_tcsigs)

lemma wf_osig_iff_exe_wf_osig: "wf_osig (translate_osig oss) \<longleftrightarrow> exe_wf_osig oss"
  using exe_wf_osig_imp_wf_osig wf_osig_imp_exe_wf_osig by blast

end


section{* Verification Component with Forward Reasoning Based on KAD *}

theory VC_KAD_dual
  imports VC_KAD
begin

context modal_kleene_algebra
begin

subsection {* Basic Forward Transformer Calculus *}

lemma r_ad [simp]: "r (ad p) = ad p"
  using a_closure addual.ars_r_def am_d_def domrangefix by auto

lemma bdia_export2: "r p \<cdot> \<langle>x| q = \<langle>x \<cdot> r p| q"
  using ardual.ads_d_def ardual.am2 ardual.fdia_export_2 bdia_def by auto

lemma bdia_seq [simp]: "\<langle>x \<cdot> y| q = \<langle>y| \<langle>x| q"
  by (simp add: ardual.ds.fdia_mult)

lemma bdia_seq_var: "\<langle>x| p \<le> p' \<Longrightarrow> \<langle>y| p' \<le> q \<Longrightarrow> \<langle>x \<cdot> y| p \<le> q"
  by (metis ardual.ds.fd_subdist_1 ardual.ds.fdia_mult dual_order.trans join.sup_absorb2)

lemma bdia_cond_var [simp]: "\<langle>if p then x else y fi| q = \<langle>x| (d p \<cdot> r q) + \<langle>y| (ad p \<cdot> r q)"
  by (metis (no_types, lifting) bdia_export1 a4' a_de_morgan a_de_morgan_var_3 a_subid_aux1' ardual.ds.fdia_add2 dka.dnso1 dka.dsg4 domrange dpdz.dnso1 cond_def join.sup.absorb_iff1 rangedom)

lemma bdia_while: "\<langle>x| (d t \<cdot> r p) \<le> r p  \<Longrightarrow> \<langle>while t do x od| p \<le> r p \<cdot> ad t"
proof -
  assume "\<langle>x| (d t \<cdot> r p) \<le> r p"
  hence "\<langle>d t \<cdot> x| p \<le> r p"
    by (metis bdia_export1 dka.dsg4 domrange rangedom)
  hence "\<langle>(d t \<cdot> x)\<^sup>\<star>| p \<le> r p"
    by (meson ardual.fdemodalisation22 ardual.kat_2_equiv_opp star_sim1)
  hence "r (ad t) \<cdot> \<langle>(d t \<cdot> x)\<^sup>\<star>| p \<le> r p \<cdot> ad t"
    by (metis ardual.dpdz.dsg4 ars_r_def mult_isol r_ad)
  thus ?thesis
    by (metis bdia_export2 while_def r_ad)
qed

lemma bdia_whilei: "r p \<le> r i \<Longrightarrow> r i \<cdot> ad t \<le> r q \<Longrightarrow> \<langle>x| (d t \<cdot> r i) \<le> r i \<Longrightarrow> \<langle>while t inv i do x od| p \<le> r q"
proof -
  assume a1: "r p \<le> r i" and a2: "r i \<cdot> ad t \<le> r q" and "\<langle>x| (d t \<cdot> r i) \<le> r i"
  hence "\<langle>while t inv i do x od| i \<le> r i \<cdot> ad t"
    by (simp add: bdia_while whilei_def)
  hence "\<langle>while t inv i do x od| i \<le> r q"
    using a2 dual_order.trans by blast
  hence "r i \<le> |while t inv i do x od] r q"
    using ars_r_def box_diamond_galois_1 domrange by fastforce
  hence "r p \<le> |while t inv i do x od] r q"
    using a1 dual_order.trans by blast
  thus ?thesis
    using ars_r_def box_diamond_galois_1 domrange by fastforce
qed

lemma bdia_whilei_break: "\<langle>y| p \<le> r i \<Longrightarrow> r i \<cdot> ad t \<le> r q \<Longrightarrow> \<langle>x| (d t \<cdot> r i) \<le> r i \<Longrightarrow> \<langle>y \<cdot> (while t inv i do x od)| p \<le> r q"
  using bdia_whilei ardual.ads_d_def ardual.ds.fdia_mult bdia_def by auto

end

subsection {* Floyd's Assignment Rule *}

lemma bdia_assign [simp]: "rel_antirange_kleene_algebra.bdia (v ::= e) \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<exists>w. s v = e (s(v := w)) \<and> P (s(v:=w))\<rceil>"
  apply (simp add: rel_antirange_kleene_algebra.bdia_def gets_def p2r_def rel_ar_def)
  apply safe
  by (metis fun_upd_apply fun_upd_triv fun_upd_upd, fastforce)

lemma d_p2r [simp]: "rel_antirange_kleene_algebra.ars_r  \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: p2r_def rel_antirange_kleene_algebra.ars_r_def rel_ar_def)

abbreviation fspec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("FPRE _ _ POST _" [64,64,64] 63) where
  "FPRE P X POST Q \<equiv> rel_antirange_kleene_algebra.bdia X \<lceil>P\<rceil> \<subseteq> rel_antirange_kleene_algebra.ars_r \<lceil>Q\<rceil>"

end


(*  Title:      ZF/UNITY/Constrains.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Weak Safety Properties\<close>

theory Constrains
imports UNITY
begin

consts traces :: "[i, i] => i"
  (* Initial states and program => (final state, reversed trace to it)...
      the domain may also be state*list(state) *)
inductive
  domains
     "traces(init, acts)" <=
         "(init \<union> (\<Union>act\<in>acts. field(act)))*list(\<Union>act\<in>acts. field(act))"
  intros
         (*Initial trace is empty*)
    Init: "s: init ==> <s,[]> \<in> traces(init,acts)"

    Acts: "[| act:acts;  <s,evs> \<in> traces(init,acts);  <s,s'>: act |]
           ==> <s', Cons(s,evs)> \<in> traces(init, acts)"

  type_intros list.intros UnI1 UnI2 UN_I fieldI2 fieldI1

consts reachable :: "i=>i"
inductive
  domains
  "reachable(F)" \<subseteq> "Init(F) \<union> (\<Union>act\<in>Acts(F). field(act))"
  intros
    Init: "s:Init(F) ==> s:reachable(F)"

    Acts: "[| act: Acts(F);  s:reachable(F);  <s,s'>: act |]
           ==> s':reachable(F)"

  type_intros UnI1 UnI2 fieldI2 UN_I

definition
  Constrains :: "[i,i] => i"  (infixl \<open>Co\<close> 60)  where
  "A Co B == {F:program. F:(reachable(F) \<inter> A) co B}"

definition
  op_Unless  :: "[i, i] => i"  (infixl \<open>Unless\<close> 60)  where
  "A Unless B == (A-B) Co (A \<union> B)"

definition
  Stable     :: "i => i"  where
  "Stable(A) == A Co A"

definition
  (*Always is the weak form of "invariant"*)
  Always :: "i => i"  where
  "Always(A) == initially(A) \<inter> Stable(A)"

(*** traces and reachable ***)

lemma reachable_type: "reachable(F) \<subseteq> state"
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in reachable.dom_subset, blast)
done

lemma st_set_reachable: "st_set(reachable(F))"
apply (unfold st_set_def)
apply (rule reachable_type)
done
declare st_set_reachable [iff]

lemma reachable_Int_state: "reachable(F) \<inter> state = reachable(F)"
by (cut_tac reachable_type, auto)
declare reachable_Int_state [iff]

lemma state_Int_reachable: "state \<inter> reachable(F) = reachable(F)"
by (cut_tac reachable_type, auto)
declare state_Int_reachable [iff]

lemma reachable_equiv_traces:
"F \<in> program ==> reachable(F)={s \<in> state. \<exists>evs. <s,evs>:traces(Init(F), Acts(F))}"
apply (rule equalityI, safe)
apply (blast dest: reachable_type [THEN subsetD])
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

lemma Init_into_reachable: "Init(F) \<subseteq> reachable(F)"
by (blast intro: reachable.intros)

lemma stable_reachable: "[| F \<in> program; G \<in> program;
    Acts(G) \<subseteq> Acts(F)  |] ==> G \<in> stable(reachable(F))"
apply (blast intro: stableI constrainsI st_setI
             reachable_type [THEN subsetD] reachable.intros)
done

declare stable_reachable [intro!]
declare stable_reachable [simp]

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable:
   "F \<in> program ==> F \<in> invariant(reachable(F))"
apply (unfold invariant_def initially_def)
apply (blast intro: reachable_type [THEN subsetD] reachable.intros)
done

(*...in fact the strongest invariant!*)
lemma invariant_includes_reachable: "F \<in> invariant(A) ==> reachable(F) \<subseteq> A"
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in reachable_type)
apply (simp (no_asm_use) add: stable_def constrains_def invariant_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

(*** Co ***)

lemma constrains_reachable_Int: "F \<in> B co B'==>F:(reachable(F) \<inter> B) co (reachable(F) \<inter> B')"
apply (frule constrains_type [THEN subsetD])
apply (frule stable_reachable [OF _ _ subset_refl])
apply (simp_all add: stable_def constrains_Int)
done

(*Resembles the previous definition of Constrains*)
lemma Constrains_eq_constrains:
"A Co B = {F \<in> program. F:(reachable(F) \<inter> A) co (reachable(F)  \<inter>  B)}"
apply (unfold Constrains_def)
apply (blast dest: constrains_reachable_Int constrains_type [THEN subsetD]
             intro: constrains_weaken)
done

lemmas Constrains_def2 = Constrains_eq_constrains [THEN eq_reflection]

lemma constrains_imp_Constrains: "F \<in> A co A' ==> F \<in> A Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L dest: constrainsD2)
done

lemma ConstrainsI:
    "[|!!act s s'. [| act \<in> Acts(F); <s,s'>:act; s \<in> A |] ==> s':A';
       F \<in> program|]
     ==> F \<in> A Co A'"
apply (auto simp add: Constrains_def constrains_def st_set_def)
apply (blast dest: reachable_type [THEN subsetD])
done

lemma Constrains_type:
 "A Co B \<subseteq> program"
apply (unfold Constrains_def, blast)
done

lemma Constrains_empty: "F \<in> 0 Co B \<longleftrightarrow> F \<in> program"
by (auto dest: Constrains_type [THEN subsetD]
            intro: constrains_imp_Constrains)
declare Constrains_empty [iff]

lemma Constrains_state: "F \<in> A Co state \<longleftrightarrow> F \<in> program"
apply (unfold Constrains_def)
apply (auto dest: Constrains_type [THEN subsetD] intro: constrains_imp_Constrains)
done
declare Constrains_state [iff]

lemma Constrains_weaken_R:
        "[| F \<in> A Co A'; A'<=B' |] ==> F \<in> A Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "[| F \<in> A Co A'; B<=A |] ==> F \<in> B Co A'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_L st_set_subset)
done

lemma Constrains_weaken:
   "[| F \<in> A Co A'; B<=A; A'<=B' |] ==> F \<in> B Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken st_set_subset)
done

(** Union **)
lemma Constrains_Un:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def2, auto)
apply (simp add: Int_Un_distrib)
apply (blast intro: constrains_Un)
done

lemma Constrains_UN:
    "[|(!!i. i \<in> I==>F \<in> A(i) Co A'(i)); F \<in> program|]
     ==> F:(\<Union>i \<in> I. A(i)) Co (\<Union>i \<in> I. A'(i))"
by (auto intro: constrains_UN simp del: UN_simps
         simp add: Constrains_def2 Int_UN_distrib)

(** Intersection **)

lemma Constrains_Int:
    "[| F \<in> A Co A'; F \<in> B Co B'|]==> F:(A \<inter> B) Co (A' \<inter> B')"
apply (unfold Constrains_def)
apply (subgoal_tac "reachable (F) \<inter> (A \<inter> B) = (reachable (F) \<inter> A) \<inter> (reachable (F) \<inter> B) ")
apply (auto intro: constrains_Int)
done

lemma Constrains_INT:
    "[| (!!i. i \<in> I ==>F \<in> A(i) Co A'(i)); F \<in> program  |]
     ==> F:(\<Inter>i \<in> I. A(i)) Co (\<Inter>i \<in> I. A'(i))"
apply (simp (no_asm_simp) del: INT_simps add: Constrains_def INT_extend_simps)
apply (rule constrains_INT)
apply (auto simp add: Constrains_def)
done

lemma Constrains_imp_subset: "F \<in> A Co A' ==> reachable(F) \<inter> A \<subseteq> A'"
apply (unfold Constrains_def)
apply (blast dest: constrains_imp_subset)
done

lemma Constrains_trans:
 "[| F \<in> A Co B; F \<in> B Co C |] ==> F \<in> A Co C"
apply (unfold Constrains_def2)
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
"[| F \<in> A Co (A' \<union> B); F \<in> B Co B' |] ==> F \<in> A Co (A' \<union> B')"
apply (unfold Constrains_def2)
apply (simp (no_asm_use) add: Int_Un_distrib)
apply (blast intro: constrains_cancel)
done

(*** Stable ***)
(* Useful because there's no Stable_weaken.  [Tanja Vos] *)

lemma stable_imp_Stable:
"F \<in> stable(A) ==> F \<in> Stable(A)"

apply (unfold stable_def Stable_def)
apply (erule constrains_imp_Constrains)
done

lemma Stable_eq: "[| F \<in> Stable(A); A = B |] ==> F \<in> Stable(B)"
by blast

lemma Stable_eq_stable:
"F \<in> Stable(A) \<longleftrightarrow>  (F \<in> stable(reachable(F) \<inter> A))"
apply (auto dest: constrainsD2 simp add: Stable_def stable_def Constrains_def2)
done

lemma StableI: "F \<in> A Co A ==> F \<in> Stable(A)"
by (unfold Stable_def, assumption)

lemma StableD: "F \<in> Stable(A) ==> F \<in> A Co A"
by (unfold Stable_def, assumption)

lemma Stable_Un:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable(A \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable (A \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "[| F \<in> Stable(C); F \<in> A Co (C \<union> A') |]
     ==> F \<in> (C \<union> A) Co (C \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un [THEN Constrains_weaken_R])
done

lemma Stable_Constrains_Int:
    "[| F \<in> Stable(C); F \<in> (C \<inter> A) Co A' |]
     ==> F \<in> (C \<inter> A) Co (C \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int [THEN Constrains_weaken])
done

lemma Stable_UN:
    "[| (!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Union>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_UN)
done

lemma Stable_INT:
    "[|(!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Inter>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_INT)
done

lemma Stable_reachable: "F \<in> program ==>F \<in> Stable (reachable(F))"
apply (simp (no_asm_simp) add: Stable_eq_stable Int_absorb)
done

lemma Stable_type: "Stable(A) \<subseteq> program"
apply (unfold Stable_def)
apply (rule Constrains_type)
done

(*** The Elimination Theorem.  The "free" m has become universally quantified!
     Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
     in forward proof. ***)

lemma Elimination:
    "[| \<forall>m \<in> M. F \<in> ({s \<in> A. x(s) = m}) Co (B(m)); F \<in> program |]
     ==> F \<in> ({s \<in> A. x(s):M}) Co (\<Union>m \<in> M. B(m))"
apply (unfold Constrains_def, auto)
apply (rule_tac A1 = "reachable (F) \<inter> A"
        in UNITY.elimination [THEN constrains_weaken_L])
apply (auto intro: constrains_weaken_L)
done

(* As above, but for the special case of A=state *)
lemma Elimination2:
 "[| \<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} Co B(m); F \<in> program |]
     ==> F \<in> {s \<in> state. x(s):M} Co (\<Union>m \<in> M. B(m))"
apply (blast intro: Elimination)
done

(** Unless **)

lemma Unless_type: "A Unless B <=program"
apply (unfold op_Unless_def)
apply (rule Constrains_type)
done

(*** Specialized laws for handling Always ***)

(** Natural deduction rules for "Always A" **)

lemma AlwaysI:
"[| Init(F)<=A;  F \<in> Stable(A) |] ==> F \<in> Always(A)"

apply (unfold Always_def initially_def)
apply (frule Stable_type [THEN subsetD], auto)
done

lemma AlwaysD: "F \<in> Always(A) ==> Init(F)<=A & F \<in> Stable(A)"
by (simp add: Always_def initially_def)

lemmas AlwaysE = AlwaysD [THEN conjE]
lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]

(*The set of all reachable states is Always*)
lemma Always_includes_reachable: "F \<in> Always(A) ==> reachable(F) \<subseteq> A"
apply (simp (no_asm_use) add: Stable_def Constrains_def constrains_def Always_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant(A) ==> F \<in> Always(A)"
apply (unfold Always_def invariant_def Stable_def stable_def)
apply (blast intro: constrains_imp_Constrains)
done

lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]

lemma Always_eq_invariant_reachable: "Always(A) = {F \<in> program. F \<in> invariant(reachable(F) \<inter> A)}"
apply (simp (no_asm) add: Always_def invariant_def Stable_def Constrains_def2 stable_def initially_def)
apply (rule equalityI, auto)
apply (blast intro: reachable.intros reachable_type)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always(A) = {F \<in> program. reachable(F) \<subseteq> A}"
apply (rule equalityI, safe)
apply (auto dest: invariant_includes_reachable
   simp add: subset_Int_iff invariant_reachable Always_eq_invariant_reachable)
done

lemma Always_type: "Always(A) \<subseteq> program"
by (unfold Always_def initially_def, auto)

lemma Always_state_eq: "Always(state) = program"
apply (rule equalityI)
apply (auto dest: Always_type [THEN subsetD] reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)
done
declare Always_state_eq [simp]

lemma state_AlwaysI: "F \<in> program ==> F \<in> Always(state)"
by (auto dest: reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "st_set(A) ==> Always(A) = (\<Union>I \<in> Pow(A). invariant(I))"
apply (simp (no_asm) add: Always_eq_includes_reachable)
apply (rule equalityI, auto)
apply (blast intro: invariantI rev_subsetD [OF _ Init_into_reachable]
                    rev_subsetD [OF _ invariant_includes_reachable]
             dest: invariant_type [THEN subsetD])+
done

lemma Always_weaken: "[| F \<in> Always(A); A \<subseteq> B |] ==> F \<in> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(*** "Co" rules involving Always ***)
lemmas Int_absorb2 = subset_Int_iff [unfolded iff_def, THEN conjunct1, THEN mp]

lemma Always_Constrains_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) Co A') \<longleftrightarrow> (F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_def Int_assoc [symmetric])
done

lemma Always_Constrains_post: "F \<in> Always(I) ==> (F \<in> A Co (I \<inter> A')) \<longleftrightarrow>(F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_eq_constrains Int_assoc [symmetric])
done

lemma Always_ConstrainsI: "[| F \<in> Always(I);  F \<in> (I \<inter> A) Co A' |] ==> F \<in> A Co A'"
by (blast intro: Always_Constrains_pre [THEN iffD1])

(* [| F \<in> Always(I);  F \<in> A Co A' |] ==> F \<in> A Co (I \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
"[|F \<in> Always(C); F \<in> A Co A'; C \<inter> B<=A; C \<inter> A'<=B'|]==>F \<in> B Co B'"
apply (rule Always_ConstrainsI)
apply (drule_tac [2] Always_ConstrainsD, simp_all)
apply (blast intro: Constrains_weaken)
done

(** Conjoining Always properties **)
lemma Always_Int_distrib: "Always(A \<inter> B) = Always(A) \<inter> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(* the premise i \<in> I is need since \<Inter>is formally not defined for I=0 *)
lemma Always_INT_distrib: "i \<in> I==>Always(\<Inter>i \<in> I. A(i)) = (\<Inter>i \<in> I. Always(A(i)))"
apply (rule equalityI)
apply (auto simp add: Inter_iff Always_eq_includes_reachable)
done

lemma Always_Int_I: "[| F \<in> Always(A);  F \<in> Always(B) |] ==> F \<in> Always(A \<inter> B)"
apply (simp (no_asm_simp) add: Always_Int_distrib)
done

(*Allows a kind of "implication introduction"*)
lemma Always_Diff_Un_eq: "[| F \<in> Always(A) |] ==> (F \<in> Always(C-A \<union> B)) \<longleftrightarrow> (F \<in> Always(B))"
by (auto simp add: Always_eq_includes_reachable)

(*Delete the nearest invariance assumption (which will be the second one
  used by Always_Int_I) *)
lemmas Always_thin = thin_rl [of "F \<in> Always(A)"] for F A

(*To allow expansion of the program's definition when appropriate*)
named_theorems program "program definitions"

ML
\<open>
(*Combines two invariance ASSUMPTIONS into one.  USEFUL??*)
fun Always_Int_tac ctxt =
  dresolve_tac ctxt @{thms Always_Int_I} THEN'
  assume_tac ctxt THEN'
  eresolve_tac ctxt @{thms Always_thin};

(*Combines a list of invariance THEOREMS into one.*)
val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I});

(*proves "co" properties when the program is specified*)

fun constrains_tac ctxt =
   SELECT_GOAL
      (EVERY [REPEAT (Always_Int_tac ctxt 1),
              REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1
                      ORELSE
                      resolve_tac ctxt [@{thm StableI}, @{thm stableI},
                                   @{thm constrains_imp_Constrains}] 1),
              resolve_tac ctxt @{thms constrainsI} 1,
              (* Three subgoals *)
              rewrite_goal_tac ctxt [@{thm st_set_def}] 3,
              REPEAT (force_tac ctxt 2),
              full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt \<^named_theorems>\<open>program\<close>)) 1,
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              ALLGOALS (asm_full_simp_tac ctxt),
              ALLGOALS (clarify_tac ctxt)]);

(*For proving invariants*)
fun always_tac ctxt i =
  resolve_tac ctxt @{thms AlwaysI} i THEN
  force_tac ctxt i
  THEN constrains_tac ctxt i;
\<close>

method_setup safety = \<open>
  Scan.succeed (SIMPLE_METHOD' o constrains_tac)\<close>
  "for proving safety properties"

method_setup always = \<open>
  Scan.succeed (SIMPLE_METHOD' o always_tac)\<close>
  "for proving invariants"

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Transport for HOL Type Definitions\<close>
theory Transport_Typedef_Base
  imports
    Transport.Transport_Bijections
    HOL.Typedef
begin

overloading
  eq_restrict_set \<equiv> "eq_restrict :: 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
begin
  definition "eq_restrict_set (S :: 'a set) \<equiv> ((=\<^bsub>\<lambda>x. x \<in> S\<^esub>) :: 'a \<Rightarrow> _)"
end

lemma eq_restrict_set_eq_eq_restrict_pred [simp]:
  "((=\<^bsub>S :: 'a set\<^esub>) :: 'a \<Rightarrow> _) = (=\<^bsub>\<lambda>x. x \<in> S\<^esub>)"
  unfolding eq_restrict_set_def by simp

lemma eq_restrict_set_iff_eq_restrict_pred [iff]:
  "(x :: 'a) =\<^bsub>(S :: 'a set)\<^esub> y \<longleftrightarrow> x =\<^bsub>(\<lambda>x. x \<in> S)\<^esub> y"
  by simp

overloading
  restrict_left_set \<equiv> "restrict_left :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a set) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
begin
  definition "restrict_left_set (R :: 'a \<Rightarrow> _) (S :: 'a set) \<equiv> R\<restriction>\<^bsub>\<lambda>x. x \<in> S\<^esub>"
end

lemma restrict_left_set_eq_restrict_left_pred [simp]:
  "(R\<restriction>\<^bsub>S :: 'a set\<^esub> :: 'a \<Rightarrow> _) = R\<restriction>\<^bsub>\<lambda>x. x \<in> S\<^esub>"
  unfolding restrict_left_set_def by simp

lemma restrict_left_set_iff_restrict_left_pred [iff]:
  "(R\<restriction>\<^bsub>S :: 'a set\<^esub> :: 'a \<Rightarrow> _) x y \<longleftrightarrow> R\<restriction>\<^bsub>\<lambda>x. x \<in> S\<^esub> x y"
  by simp

context type_definition
begin

abbreviation (input) "L :: 'a \<Rightarrow> 'a \<Rightarrow> bool \<equiv> (=\<^bsub>A\<^esub>)"
abbreviation (input) "R :: 'b \<Rightarrow> 'b \<Rightarrow> bool \<equiv> (=)"

sublocale transport? :
  transport_eq_restrict_bijection "\<lambda>x. x \<in> A" "\<top> :: 'b \<Rightarrow> bool" Abs Rep
  rewrites "(=\<^bsub>\<lambda>(x :: 'a). x \<in> A\<^esub>) \<equiv> L"
  and "(=\<^bsub>\<top> :: 'b \<Rightarrow> bool\<^esub>) \<equiv> R"
  and "(galois_rel.Galois (=) (=) Rep)\<restriction>\<^bsub>\<lambda>x. x \<in> A\<^esub>\<upharpoonleft>\<^bsub>\<top> :: 'b \<Rightarrow> bool\<^esub> \<equiv>
    (galois_rel.Galois (=) (=) Rep)\<restriction>\<^bsub>A\<^esub>"
  using Rep Abs_inverse Rep_inverse
  by (intro transport_eq_restrict_bijection.intro bijection_onI)
  (auto simp: restrict_right_eq)

interpretation galois L R Abs Rep .

lemma Galois_Rep_self: "Rep y \<^bsub>L\<^esub>\<lessapprox> y"
  using Rep by (intro GaloisI) auto

end

end


(*
   Title: Psi-calculi
   Based on the AFP entry by 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 bisim_par_comm 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 bisim_res_comm 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 bisim_res_comm' 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 bisim_scope_ext 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 bisim_scope_ext_chain 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 bisim_par_assoc strongBisimWeakBisim)

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

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<approx> P"
by(metis bisim_par_nil 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 bisim_res_nil 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 bisim_output_push_res 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 bisim_input_push_res 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 bisim_case_push_res strongBisimWeakBisim)

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

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<approx> P \<parallel> !P"
using assms
by(metis bang_ext 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     "extract_frame 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 guarded_frame_stat_eq:
  fixes P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

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

  with `guarded P` have "\<Psi>\<^sub>P \<simeq> \<one>" and "((supp \<Psi>\<^sub>P)::name set) = {}"
    by(metis guarded_stat_eq)+
  from `supp \<Psi>\<^sub>P = {}` 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: frame_res_fresh_chain)
  moreover from `\<Psi>\<^sub>P \<simeq> \<one>` have  "\<langle>[], \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>[], \<one>\<rangle>"
    by(simp add: Frame_stat_eq_def Frame_stat_imp_def Assertion_stat_eq_def Assertion_stat_imp_def)
  ultimately show ?thesis using FrR by(rule_tac Frame_stat_eq_trans) auto
qed

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

  assumes "guarded P"

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

  with `guarded P` have "\<Psi>\<^sub>P \<simeq> \<one>" and "((supp \<Psi>\<^sub>P)::name set) = {}"
    by(metis guarded_stat_eq)+
  from `supp \<Psi>\<^sub>P = {}` 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 `A\<^sub>P \<sharp>* \<Psi>` by(force intro: frame_res_fresh_chain)
  moreover from `\<Psi>\<^sub>P \<simeq> \<one>` have  "\<langle>\<epsilon>, \<Psi> \<otimes> \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi> \<otimes> \<one>\<rangle>" by(force intro: composition_sym)
  moreover have "\<langle>\<epsilon>, \<Psi> \<otimes> \<one>\<rangle> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(force intro: Identity)
  ultimately show ?thesis using FrR `A\<^sub>P \<sharp>* \<Psi>`
    by(force intro: Frame_stat_eq_trans Assertion_stat_eq_trans)
qed

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

  shows "insert_assertion(insert_assertion F \<Psi>) \<Psi>' \<simeq>\<^sub>F (insert_assertion 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 fresh_frame) auto
  thus ?thesis
    by auto (metis frame_int_associativity Frame_stat_eq_sym)
qed

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

  obtains Q \<pi>' where "\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> !P"
proof -
  assume "\<And>\<pi>' Q. \<lbrakk>\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q; P' \<sim> Q \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from `\<Psi> \<rhd> !P \<longmapsto>\<pi> @ \<alpha> \<prec> P'` `bn \<alpha> \<sharp>* subject \<alpha>` `\<alpha> \<noteq> \<tau>` `bn \<alpha> \<sharp>* P`  have "\<exists>Q \<pi>'. \<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
  proof(nominal_induct rule: bang_induct')
    case(c_alpha \<pi> \<alpha> P' p)
    then obtain \<pi>' Q where "\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by fastforce
    from `\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q` have "distinct(bn \<alpha>)" by(rule bound_output_distinct)
    have S: "set p \<subseteq> set(bn \<alpha>) \<times> set(bn(p \<bullet> \<alpha>))" by fact
    from `\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q` `bn(p \<bullet> \<alpha>) \<sharp>* \<alpha>` `bn(p \<bullet> \<alpha>) \<sharp>* P` `bn \<alpha> \<sharp>* subject \<alpha>` `distinct(bn \<alpha>)`
    have "bn(p \<bullet> \<alpha>) \<sharp>* Q" by(force dest: free_fresh_chain_derivative)
    with `\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q` `bn(p \<bullet> \<alpha>) \<sharp>* \<alpha>` S `bn \<alpha> \<sharp>* subject \<alpha>` `distinct(bn \<alpha>)` have "\<Psi> \<rhd> P \<longmapsto>\<pi>' @ (p \<bullet> \<alpha>) \<prec> (p \<bullet> Q)"
      by(fastforce simp add: residual_alpha)
    moreover from `P' \<sim> Q \<parallel> (P \<parallel> !P)` have "(p \<bullet> \<one>) \<rhd> (p \<bullet> P') \<sim> (p \<bullet> (Q \<parallel> (P \<parallel> !P)))"
      by(rule bisim_closed)
    with `(bn \<alpha>) \<sharp>* P` `bn(p \<bullet> \<alpha>) \<sharp>* P` S have "(p \<bullet> P') \<sim> (p \<bullet> Q) \<parallel> (P \<parallel> !P)"
      by(simp add: eqvts)
    ultimately show ?case by blast
  next
    case(c_par1 \<pi> \<alpha> P')
    from `guarded P` have "P' \<parallel> !P \<sim> P' \<parallel> (P \<parallel> !P)" by(metis bang_ext bisim_par_pres_sym)
    with `\<Psi> \<rhd> P \<longmapsto>\<pi> @ \<alpha> \<prec> P'` show ?case by blast
  next
    case(c_par2 \<pi> \<alpha> P')
    then obtain Q \<pi>' where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> !P" by blast
    from `P' \<sim> Q \<parallel> !P` have "P \<parallel> P' \<sim> Q \<parallel> (P \<parallel> !P)"
      by(metis bisim_par_pres_sym bisim_par_assoc bisim_transitive bisim_par_comm)
    with PTrans show ?case by blast
  next
    case c_comm1
    from `\<tau> \<noteq> \<tau>` have False by simp
    thus ?case by simp
  next
    case c_comm2
    from `\<tau> \<noteq> \<tau>` have False by simp
    thus ?case by simp
  next
    case(c_bang \<pi> \<alpha> P')
    then obtain Q \<pi>' where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by blast
    from `P' \<sim> Q \<parallel> (P \<parallel> !P)` `guarded P` have "P' \<sim> Q \<parallel> !P" by(metis bisim_transitive bisim_par_pres_sym bang_ext bisim_symmetric)
    with PTrans show ?case by blast
  qed
  ultimately show ?thesis by blast
qed

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

  obtains Q where "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> Q" and "P' \<sim> Q \<parallel> !P"
using assms
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> P \<parallel> P\<longmapsto>None @ \<tau> \<prec> Q; P' \<sim> Q \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from assms have "\<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
  proof(nominal_induct rule: bang_tau_induct)
    case(c_par1 P')
    obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extract_frame 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 fresh_frame) auto
    from `guarded P` FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guarded_stat_eq) auto
    with `\<Psi> \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'` have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'"
      thm stat_eq_transition
      by(rule_tac stat_eq_transition, auto) (metis Identity Assertion_stat_eq_sym composition_sym Assertion_stat_eq_trans)
    hence "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> P' \<parallel> P" using FrP `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P` by(rule_tac Par1[where \<pi>=None,simplified]) auto
    moreover from `guarded P` have "P' \<parallel> !P \<sim> (P' \<parallel> P) \<parallel> (P \<parallel> !P)"
      by(metis bisim_par_pres_sym bisim_par_assoc bisim_transitive bisim_par_comm bang_ext)
    ultimately show ?case by blast
  next
    case(c_par2 P')
    then obtain n Q where PTrans: "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> Q" and "P' \<sim> Q \<parallel> !P" by blast
    from `P' \<sim> Q \<parallel> !P` have "P \<parallel> P' \<sim> Q \<parallel> (P \<parallel> !P)"
      by(metis bisim_par_pres_sym bisim_par_assoc bisim_transitive bisim_par_comm)
    with PTrans show ?case by blast
  next
    case(c_comm1 M N P' K xvec A\<^sub>P \<Psi>\<^sub>P yvec zvec P'')
    have FrP: "extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" by fact
    from `guarded P` FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guarded_stat_eq) auto
    from `\<Psi> \<rhd> !P \<longmapsto>Some (\<langle>\<epsilon>, \<langle>zvec, M\<rangle>\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''` `guarded P` `xvec \<sharp>* P` `xvec \<sharp>* K`
    obtain Q \<pi> where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<pi> @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q" and "P'' \<sim> Q \<parallel> !P"
      by(drule_tac bangActE) auto
    moreover from PTrans obtain A\<^sub>P' \<Psi>\<^sub>P' uvec M' where FrP': "extract_frame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>"
      and \<pi>: "\<pi> = Some(\<langle>A\<^sub>P'; uvec, M'\<rangle>)" and "distinct A\<^sub>P'" and "distinct uvec"
      and "A\<^sub>P' \<sharp>* \<Psi>" and "A\<^sub>P' \<sharp>* uvec" and M'eqK: "\<Psi> \<otimes> \<Psi>\<^sub>P' \<turnstile> M' \<leftrightarrow> K"
      and "A\<^sub>P' \<sharp>* Q" and "A\<^sub>P' \<sharp>* M" and "A\<^sub>P' \<sharp>* K"
      and "A\<^sub>P' \<sharp>* xvec" and "A\<^sub>P' \<sharp>* yvec" and "A\<^sub>P' \<sharp>* P" and "A\<^sub>P' \<sharp>* A\<^sub>P"
      and "uvec \<sharp>* Q" and "uvec \<sharp>* M" and "uvec \<sharp>* K"
      and "uvec \<sharp>* xvec" and "uvec \<sharp>* yvec" and "uvec \<sharp>* \<Psi>" and "uvec \<sharp>* P" and "uvec \<sharp>* A\<^sub>P"
      unfolding residual_inject
      by(drule_tac output_provenance[where C="(\<Psi>,Q, K, M, xvec, yvec, A\<^sub>P)"]) auto
    from `guarded P` FrP' have "\<Psi>\<^sub>P' \<simeq> \<one>" by(drule_tac guarded_stat_eq) auto
    from `A\<^sub>P \<sharp>* P` `A\<^sub>P' \<sharp>* A\<^sub>P` FrP' have "A\<^sub>P \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    from `yvec \<sharp>* P` `A\<^sub>P' \<sharp>* yvec` FrP' have "yvec \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    from `A\<^sub>P \<sharp>* P` PTrans have "A\<^sub>P \<sharp>* \<pi>" by(rule_tac trans_fresh_provenance)
    hence "A\<^sub>P \<sharp>* M'" using `uvec \<sharp>* A\<^sub>P` `A\<^sub>P' \<sharp>* A\<^sub>P` unfolding \<pi>
      by (simp add: frame_chain_fresh_chain'')
    from `yvec \<sharp>* P` PTrans have "yvec \<sharp>* \<pi>" by(rule_tac trans_fresh_provenance)
    hence "yvec \<sharp>* M'" using `uvec \<sharp>* yvec` `A\<^sub>P' \<sharp>* yvec` unfolding \<pi>
      by (simp add: frame_chain_fresh_chain'')
    from `uvec \<sharp>* P` `A\<^sub>P' \<sharp>* uvec` FrP' have "uvec \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    have M'eqK': "\<Psi> \<otimes> \<Psi>\<^sub>P' \<otimes> \<Psi>\<^sub>P \<turnstile> M' \<leftrightarrow> K" using `\<Psi>\<^sub>P \<simeq> \<one>`
      by (meson Assertion_stat_eq_def Associativity Identity M'eqK assertion.composition_sym assertion_axioms stat_imp_ent)
    from `\<Psi>\<^sub>P' \<simeq> \<one>` `\<Psi> \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>N\<rparr> \<prec> P'` have "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>N\<rparr> \<prec> P'"
      by(rule_tac stat_eq_transition, auto) (metis Identity Assertion_stat_eq_sym composition_sym Assertion_stat_eq_trans)
    hence "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M'\<lparr>N\<rparr> \<prec> P'" using `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` M'eqK'
      Frame_stat_imp_refl `distinct A\<^sub>P` `A\<^sub>P' \<sharp>* A\<^sub>P` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>\<^sub>P'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M'`
       `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `distinct yvec` `yvec \<sharp>* A\<^sub>P` `yvec \<sharp>* \<Psi>\<^sub>P'` `yvec \<sharp>* \<Psi>` `yvec \<sharp>* M'`
       `yvec \<sharp>* P` `A\<^sub>P' \<sharp>* yvec`
      by(rule_tac comm2_aux[where A\<^sub>P="A\<^sub>P'"]) (assumption|simp)+
    moreover from PTrans `\<Psi>\<^sub>P \<simeq> \<one>` have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>\<pi> @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q"
      by(rule_tac stat_eq_transition, auto) (metis Identity Assertion_stat_eq_sym composition_sym Assertion_stat_eq_trans)
    ultimately have "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)" using FrP FrP' `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M` `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `A\<^sub>P' \<sharp>* A\<^sub>P` `xvec \<sharp>* P`
      unfolding \<pi> using `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* P` `uvec \<sharp>* \<Psi>` `uvec \<sharp>* P` `uvec \<sharp>* \<Psi>\<^sub>P'`
      by(rule_tac Comm1) (assumption | simp)+
    moreover from `P'' \<sim> Q \<parallel> !P` `guarded P` have "P' \<parallel> P'' \<sim> (P' \<parallel> Q) \<parallel> (P \<parallel> !P)"
      by(metis bisim_transitive bang_ext bisim_par_pres_sym bisim_par_assoc bisim_symmetric)
    hence "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> Q) \<parallel> (P \<parallel> !P))" by(rule_tac bisim_res_chain_pres) auto
    with `xvec \<sharp>* P` `xvec \<sharp>* \<Psi>` have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)) \<parallel> (P \<parallel> !P)"
      by(force intro: bisim_transitive bisim_scope_ext_chain_sym)
    ultimately show ?case by blast
  next
    case(c_comm2 M xvec N P' K A\<^sub>P \<Psi>\<^sub>P yvec zvec P'')
    have FrP: "extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" by fact
    from `guarded P` FrP have "\<Psi>\<^sub>P \<simeq> \<one>" by(drule_tac guarded_stat_eq) auto
    from `\<Psi> \<rhd> !P \<longmapsto>_ @ _ \<prec> P''` `guarded P` `xvec \<sharp>* P` `xvec \<sharp>* K`
    obtain Q \<pi> where PTrans: "\<Psi> \<rhd> P \<longmapsto>\<pi> @ K\<lparr>N\<rparr> \<prec> Q" and "P'' \<sim> Q \<parallel> !P"
      by(drule_tac bangActE) auto
    moreover from PTrans obtain A\<^sub>P' \<Psi>\<^sub>P' uvec M' where FrP': "extract_frame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>"
      and \<pi>: "\<pi> = Some(\<langle>A\<^sub>P'; uvec, M'\<rangle>)" and "distinct A\<^sub>P'" and "distinct uvec"
      and "A\<^sub>P' \<sharp>* \<Psi>" and "A\<^sub>P' \<sharp>* uvec" and M'eqK: "\<Psi> \<otimes> \<Psi>\<^sub>P' \<turnstile> K \<leftrightarrow> M'"
      and "A\<^sub>P' \<sharp>* Q" and "A\<^sub>P' \<sharp>* M" and "A\<^sub>P' \<sharp>* K"
      and "A\<^sub>P' \<sharp>* xvec" and "A\<^sub>P' \<sharp>* yvec" and "A\<^sub>P' \<sharp>* P" and "A\<^sub>P' \<sharp>* A\<^sub>P"
      and "uvec \<sharp>* Q" and "uvec \<sharp>* M" and "uvec \<sharp>* K"
      and "uvec \<sharp>* xvec" and "uvec \<sharp>* yvec" and "uvec \<sharp>* \<Psi>" and "uvec \<sharp>* P" and "uvec \<sharp>* A\<^sub>P"
      by(drule_tac input_provenance[where C="(\<Psi>,Q, K, M, xvec, yvec, A\<^sub>P)"]) auto
    from `guarded P` FrP' have "\<Psi>\<^sub>P' \<simeq> \<one>" by(drule_tac guarded_stat_eq) auto
    from `A\<^sub>P \<sharp>* P` `A\<^sub>P' \<sharp>* A\<^sub>P` FrP' have "A\<^sub>P \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    from `yvec \<sharp>* P` `A\<^sub>P' \<sharp>* yvec` FrP' have "yvec \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    from `A\<^sub>P \<sharp>* P` PTrans have "A\<^sub>P \<sharp>* \<pi>" by(rule_tac trans_fresh_provenance)
    hence "A\<^sub>P \<sharp>* M'" using `uvec \<sharp>* A\<^sub>P` `A\<^sub>P' \<sharp>* A\<^sub>P` unfolding \<pi>
      by (simp add: frame_chain_fresh_chain'')
    from `yvec \<sharp>* P` PTrans have "yvec \<sharp>* \<pi>" by(rule_tac trans_fresh_provenance)
    hence "yvec \<sharp>* M'" using `uvec \<sharp>* yvec` `A\<^sub>P' \<sharp>* yvec` unfolding \<pi>
      by (simp add: frame_chain_fresh_chain'')
    from `uvec \<sharp>* P` `A\<^sub>P' \<sharp>* uvec` FrP' have "uvec \<sharp>* \<Psi>\<^sub>P'" by(auto dest: extract_frame_fresh_chain)
    have M'eqK': "\<Psi> \<otimes> \<Psi>\<^sub>P' \<otimes> \<Psi>\<^sub>P \<turnstile> K \<leftrightarrow> M'" using M'eqK `\<Psi>\<^sub>P \<simeq> \<one>` `\<Psi>\<^sub>P' \<simeq> \<one>`
      by (metis Assertion_stat_eq_def Assertion_stat_eq_trans Assertion_stat_imp_def Composition' Identity)
    from `\<Psi>\<^sub>P' \<simeq> \<one>` `\<Psi> \<rhd> P \<longmapsto>_ @ _ \<prec> P'` have "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
      by(rule_tac stat_eq_transition, auto) (metis Identity Assertion_stat_eq_sym composition_sym Assertion_stat_eq_trans)
    hence "\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M'\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'" using `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` M'eqK'
      Frame_stat_imp_refl `distinct A\<^sub>P` `A\<^sub>P' \<sharp>* A\<^sub>P` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>\<^sub>P'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M'`
       `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `distinct yvec` `yvec \<sharp>* A\<^sub>P` `yvec \<sharp>* \<Psi>\<^sub>P'` `yvec \<sharp>* \<Psi>` `yvec \<sharp>* M'`
       `yvec \<sharp>* P` `A\<^sub>P' \<sharp>* yvec`
      by(rule_tac comm1_aux[where A\<^sub>P="A\<^sub>P'"]) (assumption|simp)+
    moreover from PTrans `\<Psi>\<^sub>P \<simeq> \<one>` have "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>\<pi> @ K\<lparr>N\<rparr> \<prec> Q"
      by(rule_tac stat_eq_transition, auto) (metis Identity Assertion_stat_eq_sym composition_sym Assertion_stat_eq_trans)
    ultimately have "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)" using FrP FrP' `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M` `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `A\<^sub>P' \<sharp>* A\<^sub>P` `xvec \<sharp>* P`
      unfolding \<pi> using `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* P` `uvec \<sharp>* \<Psi>` `uvec \<sharp>* P` `uvec \<sharp>* \<Psi>\<^sub>P'`
      by(rule_tac Comm2) (assumption | simp)+
    moreover from `P'' \<sim> Q \<parallel> !P` `guarded P` have "P' \<parallel> P'' \<sim> (P' \<parallel> Q) \<parallel> (P \<parallel> !P)"
      by(metis bisim_transitive bang_ext bisim_par_pres_sym bisim_par_assoc bisim_symmetric)
    hence "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> \<lparr>\<nu>*xvec\<rparr>((P' \<parallel> Q) \<parallel> (P \<parallel> !P))" by(rule_tac bisim_res_chain_pres) auto
    with `xvec \<sharp>* P` `xvec \<sharp>* \<Psi>` have "\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'') \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> Q)) \<parallel> (P \<parallel> !P)"
      by(force intro: bisim_transitive bisim_scope_ext_chain_sym)
    ultimately show ?case by blast
  next
    case(c_bang P')
    then obtain Q where PTrans: "\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> Q" and "P' \<sim> Q \<parallel> (P \<parallel> !P)" by blast
    from `P' \<sim> Q \<parallel> (P \<parallel> !P)` `guarded P` have "P' \<sim> Q \<parallel> !P" by(metis bisim_transitive bisim_par_pres_sym bang_ext bisim_symmetric)
    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>None @ \<tau> \<prec> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> Q" and "Q \<sim> P' \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> Q; Q \<sim> P' \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from `\<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<tau> \<prec> P'` have "\<exists>Q. \<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> Q \<and> Q \<sim> P' \<parallel> !P"
  proof(induct rule: parTauCases[where C="()"])
    case(c_par1 P' A\<^sub>P \<Psi>\<^sub>P)
    from `\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'` have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'"
      by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> P' \<parallel> !P" by(rule_tac Par1[where \<pi>=None,simplified]) auto
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P' \<parallel> !P" using `guarded P` by(rule Bang[where \<pi>=None,simplified])
     hence "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P`
       by(rule_tac Par2[where \<pi>=None,simplified]) auto
     hence "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using `guarded P` by(rule Bang[where \<pi>=None,simplified])
     moreover have "P \<parallel> (P' \<parallel> !P) \<sim> P' \<parallel> P \<parallel> !P"
       by(metis bisim_par_assoc bisim_par_comm bisim_transitive bisim_symmetric bisim_par_pres)
     ultimately show ?case by blast
   next
    case(c_par2 P' A\<^sub>P \<Psi>\<^sub>P)
    from `\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'` have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'"
      by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> P' \<parallel> !P" by(rule_tac Par1[where \<pi>=None, simplified]) auto
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P' \<parallel> !P" using `guarded P` by(rule Bang[where \<pi>=None, simplified])
     hence "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P`
       by(rule_tac Par2[where \<pi>=None, simplified]) auto
     hence "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P \<parallel> (P' \<parallel> !P)" using `guarded P` by(rule Bang[where \<pi>=None, simplified])
     moreover have "P \<parallel> (P' \<parallel> !P) \<sim> P \<parallel> P' \<parallel> !P"
       by(metis bisim_par_assoc bisim_symmetric)
     ultimately show ?case by blast
   next
     case(c_comm1 \<Psi>\<^sub>P' M N P' A\<^sub>P \<Psi>\<^sub>P K xvec P'' A\<^sub>P' yvec zvec)
     from `extract_frame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>` `guarded P` have "\<Psi>\<^sub>P' \<simeq> \<one>" by(blast dest: guarded_stat_eq)
     with `\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>_ @ M\<lparr>N\<rparr> \<prec> P'` have "\<Psi> \<otimes> \<one> \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>N\<rparr> \<prec> P'"
       by(rule_tac stat_eq_transition, auto) (metis composition_sym Assertion_stat_eq_sym)
     moreover note `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
     moreover from `\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>_ @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''` have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P'; zvec, M\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P''"
       by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>Some (\<langle>A\<^sub>P'; zvec, M\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> (P'' \<parallel> !P)" using `xvec \<sharp>* P`
       by(force intro: Par1[where A\<^sub>Q="[]" and Q="!P",simplified,unfolded map_option.id[unfolded id_def]])
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>Some (\<langle>\<epsilon>, \<langle>(A\<^sub>P' @ zvec), M\<rangle>\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> (P'' \<parallel> !P)" using `guarded P`
       by(rule Bang[where \<pi>="Some (\<langle>A\<^sub>P'; zvec, M\<rangle>)",simplified])
     ultimately have "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))"
       using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>P'` `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `xvec \<sharp>* P`
             `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* P` `zvec \<sharp>* \<Psi>` `zvec \<sharp>* P`
       by(force intro: Comm1[where Q="!P" and A\<^sub>Q="[]",simplified])
     hence "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))" using `guarded P` by(rule Bang[where \<pi>=None,simplified])
     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: bisim_res_chain_pres bisim_par_assoc[THEN bisim_symmetric])
       moreover have "\<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P" using `xvec \<sharp>* P`
         by(rule_tac bisim_scope_ext_chain_sym) auto
       ultimately show ?thesis by(rule bisim_transitive)
     qed
     ultimately show ?case by blast
   next
     case(c_comm2 \<Psi>\<^sub>P' M xvec N P' A\<^sub>P \<Psi>\<^sub>P K P'' A\<^sub>P' yvec zvec)
     from `extract_frame P = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>` `guarded P` have "\<Psi>\<^sub>P' \<simeq> \<one>" by(blast dest: guarded_stat_eq)
     with `\<Psi> \<otimes> \<Psi>\<^sub>P' \<rhd> P \<longmapsto>_ @ M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle>\<prec> P'` have "\<Psi> \<otimes> \<one> \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
       by(rule_tac stat_eq_transition, auto) (metis composition_sym Assertion_stat_eq_sym)
     moreover note `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
     moreover from `\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<longmapsto>_ @ K\<lparr>N\<rparr> \<prec> P''` have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<one> \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P'; zvec, M\<rangle>) @ K\<lparr>N\<rparr> \<prec> P''"
       by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> P \<parallel> !P \<longmapsto>Some (\<langle>A\<^sub>P'; zvec, M\<rangle>) @ K\<lparr>N\<rparr> \<prec> (P'' \<parallel> !P)"
       by(force intro: Par1[where A\<^sub>Q="[]" and Q="!P",simplified,unfolded map_option.id[unfolded id_def]])
     hence "\<Psi> \<otimes> \<Psi>\<^sub>P \<rhd> !P \<longmapsto>Some (\<langle>\<epsilon>, \<langle>(A\<^sub>P' @ zvec), M\<rangle>\<rangle>) @ K\<lparr>N\<rparr> \<prec> (P'' \<parallel> !P)" using `guarded P`
       by(rule Bang[where \<pi>="Some (\<langle>A\<^sub>P'; zvec, M\<rangle>)",simplified])
     ultimately have "\<Psi> \<rhd> P \<parallel> !P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))"
       using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>P'` `A\<^sub>P' \<sharp>* \<Psi>` `A\<^sub>P' \<sharp>* P` `A\<^sub>P' \<sharp>* K` `xvec \<sharp>* P`
             `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* P` `zvec \<sharp>* \<Psi>` `zvec \<sharp>* P`
       by(force intro: Comm2[where Q="!P" and A\<^sub>Q="[]",simplified])
     hence "\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> \<lparr>\<nu>*xvec\<rparr>(P' \<parallel> (P'' \<parallel> !P))" using `guarded P` by(rule Bang[where \<pi>=None,simplified])
     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: bisim_res_chain_pres bisim_par_assoc[THEN bisim_symmetric])
       moreover have "\<lparr>\<nu>*xvec\<rparr>((P' \<parallel> P'') \<parallel> !P) \<sim> (\<lparr>\<nu>*xvec\<rparr>(P' \<parallel> P'')) \<parallel> !P" using `xvec \<sharp>* P`
         by(rule_tac bisim_scope_ext_chain_sym) auto
       ultimately show ?thesis by(rule bisim_transitive)
     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 `\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'` 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: tau_chain_induct)
    case tau_base
    have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> !P" by simp
    moreover have "\<Psi> \<rhd> !P \<sim> (P \<parallel> P) \<parallel> !P" using `guarded P`
      by(metis bisim_par_assoc bisim_transitive bisim_par_pres_sym bang_ext bisim_par_comm)
    ultimately show ?case by blast
  next
    case(tau_step 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 `\<Psi> \<rhd> R' \<longmapsto>None @ \<tau> \<prec> R''` have "\<Psi> \<otimes> \<one> \<rhd> R' \<longmapsto>None @ \<tau> \<prec> R''" by(rule stat_eq_transition) (metis Identity Assertion_stat_eq_sym)
    hence "\<Psi> \<rhd> R' \<parallel> !P \<longmapsto>None @ \<tau> \<prec> R'' \<parallel> !P" by(rule_tac Par1[where \<pi>=None,simplified]) auto
    with `\<Psi> \<rhd> Q \<sim> R' \<parallel> !P` obtain Q' \<pi> where QTrans: "\<Psi> \<rhd> Q \<longmapsto>\<pi> @ \<tau> \<prec> Q'" and "\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P"
      by(force dest: bisimE(2) simE)
    from PChain tau_no_provenance'[OF QTrans] have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" by(auto dest: tau_act_tau_chain)
    thus ?case using `\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P` 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: weak_stat_imp_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: bisim_closed simp add: eqvts)
      moreover assume "guarded P" and "guarded Q"
      moreover note weakBisimClosed bisim_closed weakBisimE(3) bisimE(3) weakBisimE(2) weakBisimE(4) bisimE(4) statEqWeakBisim stat_eq_bisim weakBisimTransitive bisim_transitive weakBisimParAssoc[THEN weakBisimE(4)] bisim_par_assoc[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 bisim_par_pres_sym
      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; extract_frame 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 bisim_res_chain_pres weakBisimScopeExtChainSym bisim_scope_ext_chain_sym
      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 bisim_transitive)
      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: bisim_reflexive weakBisimReflexive)
      moreover from bangActE have "\<And>\<Psi> P \<alpha> \<pi> P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<pi> @ \<alpha> \<prec> P'; bn \<alpha> \<sharp>* P; guarded P; \<alpha> \<noteq> \<tau>; bn \<alpha> \<sharp>* subject \<alpha>\<rbrakk> \<Longrightarrow> \<exists>Q \<pi>'. \<Psi> \<rhd> P \<longmapsto>\<pi>' @ \<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
        by blast
      moreover from bangTauE have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>None @ \<tau> \<prec> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>None @ \<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 Defs
  imports "HOL-IMP.Big_Step"
begin

datatype entry = Unchanged ("'_'_'_'_'_'_'_'_") | V "(int\<times>int) set"

unbundle lattice_syntax

definition chain :: "(nat \<Rightarrow> 'a::complete_lattice) \<Rightarrow> bool"
  where "chain C \<longleftrightarrow> (\<forall>n. C n \<le> C (Suc n))"

definition continuous :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> bool"
  where "continuous f \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> f (\<Squnion> (range C)) = \<Squnion> (f ` range C))"

lemma continuousD: "\<lbrakk>continuous f; chain C\<rbrakk> \<Longrightarrow> f (\<Squnion> (range C)) = \<Squnion> (f ` range C)"
  unfolding continuous_def by auto

consts A\<^sub>0 :: "entry list"

consts A\<^sub>1 :: "entry list"

consts A\<^sub>2 :: "entry list"

consts A\<^sub>3 :: "entry list"

consts A\<^sub>4 :: "entry list"

consts A\<^sub>5 :: "entry list"

consts A\<^sub>6 :: "entry list"

end