section \<open>Annotated Syntax\<close>
theory Annotated_Syntax
imports "Semantics"
begin

  text \<open>Unfold theorems to strip annotations from program, before it is defined as constant\<close>
  named_theorems vcg_annotation_defs \<open>Definitions of Annotations\<close>

  text \<open>Marker that is inserted around all annotations by the specification parser.\<close>
  definition "ANNOTATION \<equiv> \<lambda>x. x"

  subsection \<open>Annotations\<close>
  text \<open>The specification parser must interpret the annotations in the program.\<close>

  definition WHILE_annotI :: "(state \<Rightarrow> bool) \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com"
    ("(WHILE {_} _/ DO _)"  [0, 0, 61] 61)
    where [vcg_annotation_defs]: "WHILE_annotI (I::state \<Rightarrow> bool) \<equiv> While"

  lemmas annotate_whileI = WHILE_annotI_def[symmetric]

  definition WHILE_annotRVI :: "'a rel \<Rightarrow> (state \<Rightarrow> 'a) \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com"
      ("(WHILE {_} {_} {_} _/ DO _)"  [0, 0, 0, 0, 61] 61)
    where [vcg_annotation_defs]: "WHILE_annotRVI R V I \<equiv> While" for R V I

  lemmas annotate_whileRVI = WHILE_annotRVI_def[symmetric]

  definition WHILE_annotVI :: "(state \<Rightarrow> int) \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com"
    ("(WHILE {_} {_} _/ DO _)"  [0, 0, 0, 61] 61)
  where [vcg_annotation_defs]: "WHILE_annotVI V I \<equiv> While" for V I
  lemmas annotate_whileVI = WHILE_annotVI_def[symmetric]

  subsection \<open>Hoare-Triples for Annotated Commands\<close>
  text \<open>The command is a function from pre-state to command, as the annotations that are
    contained in the command may depend on the pre-state!\<close>

  type_synonym HT'_type = "program \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> (state \<Rightarrow> com) \<Rightarrow> (state \<Rightarrow> state\<Rightarrow>bool) \<Rightarrow> bool"

  definition HT'_partial :: HT'_type
    where "HT'_partial \<pi> P c Q \<equiv> (\<forall>s\<^sub>0. P s\<^sub>0 \<longrightarrow> wlp \<pi> (c s\<^sub>0) (Q s\<^sub>0) s\<^sub>0)"

  definition HT' :: HT'_type
    where "HT' \<pi> P c Q \<equiv> (\<forall>s\<^sub>0. P s\<^sub>0 \<longrightarrow> wp \<pi> (c s\<^sub>0) (Q s\<^sub>0) s\<^sub>0)"

  lemma HT'_eq_HT: "HT' \<pi> P (\<lambda>_. c) Q = HT \<pi> P c Q"
    unfolding HT_def HT'_def ..

  lemma HT'_partial_eq_HT: "HT'_partial \<pi> P (\<lambda>_. c) Q = HT_partial \<pi> P c Q"
    unfolding HT_partial_def HT'_partial_def ..

  lemmas HT'_unfolds = HT'_eq_HT HT'_partial_eq_HT

  type_synonym 'a \<Theta>elem_t = "(state\<Rightarrow>'a) \<times> ((state \<Rightarrow> bool) \<times> (state \<Rightarrow> com) \<times> (state \<Rightarrow> state\<Rightarrow>bool))"

  definition HT'set :: "program \<Rightarrow> 'a \<Theta>elem_t set \<Rightarrow> bool" where "HT'set \<pi> \<Theta> \<equiv> \<forall>(n,(P,c,Q))\<in>\<Theta>. HT' \<pi> P c Q"

  definition HT'set_r :: "_ \<Rightarrow> program \<Rightarrow> 'a \<Theta>elem_t set \<Rightarrow> bool" where "HT'set_r r \<pi> \<Theta> \<equiv> \<forall>(n,(P,c,Q))\<in>\<Theta>. HT' \<pi> (\<lambda>s. r n s \<and> P s) c Q"

  lemma HT'setI:
    assumes "wf R"
    assumes RL: "\<And>f P c Q s\<^sub>0. \<lbrakk> HT'set_r (\<lambda>f' s'. ((f' s'),(f s\<^sub>0))\<in>R ) \<pi> \<Theta>; (f,(P,c,Q))\<in>\<Theta>; P s\<^sub>0 \<rbrakk> \<Longrightarrow> wp \<pi> (c s\<^sub>0) (Q s\<^sub>0) s\<^sub>0"
    shows "HT'set \<pi> \<Theta>"
    unfolding HT'set_def HT'_def
  proof clarsimp
    fix f\<^sub>0 P c Q s\<^sub>0
    assume "(f\<^sub>0,(P,c,Q))\<in>\<Theta>" "P s\<^sub>0"
    with \<open>wf R\<close> show "wp \<pi> (c s\<^sub>0) (Q s\<^sub>0) s\<^sub>0"
    proof (induction "f\<^sub>0 s\<^sub>0" arbitrary: f\<^sub>0 c s\<^sub>0 P Q)
      case less
      note RL' = RL[of f\<^sub>0 s\<^sub>0 P, OF _ less.prems]
      show ?case
        apply (rule RL')
        unfolding HT'set_r_def HT'_def using less.hyps by auto
    qed
  qed

  lemma HT'setD:
    assumes "HT'set \<pi> (insert (f,(P,c,Q)) \<Theta>)"
    shows "HT' \<pi> P c Q" and "HT'set \<pi> \<Theta>"
    using assms unfolding HT'set_def by auto

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory AbstractArrays
imports
  "../lib/TypHeapLib"
  "../lib/WordLemmaBucket"
begin

(*
 * Return a list of addresses that contain an element for an array at location
 * "p" of length "n".
 *)
primrec
  array_addrs :: "('a::mem_type) ptr \<Rightarrow> nat \<Rightarrow> 'a ptr list"
where
  "array_addrs _ 0 = []"
| "array_addrs p (Suc n) = p # (array_addrs (p +\<^sub>p 1) n)"

declare array_addrs.simps(2) [simp del]

(* The first element is in the array if the array has non-zero length. *)
lemma hd_in_array_addrs [simp]:
  "(x \<in> set (array_addrs x n)) = (n > 0)"
  by (case_tac n, auto simp: array_addrs.simps(2))

lemma array_addrs_1 [simp]:
  "array_addrs p (Suc 0) = [p]"
  "array_addrs p 1 = [p]"
  by (auto simp: array_addrs.simps(2))

(* All array elements are aligned if the array itself is aligned. *)
lemma array_addrs_ptr_aligned:
     "\<lbrakk> x \<in> set (array_addrs p n); ptr_aligned p \<rbrakk> \<Longrightarrow> ptr_aligned x"
  apply (induct n arbitrary: x p)
   apply clarsimp
  apply (clarsimp simp: array_addrs.simps(2))
  apply (erule disjE)
   apply clarsimp
  apply atomize
  apply (drule_tac x=x in spec)
  apply (drule_tac x="p +\<^sub>p 1" in spec)
  apply (clarsimp simp: ptr_aligned_plus)
  done

(* Split off the last element in an array. *)
lemma set_array_addrs_unfold_last:
  shows "set (array_addrs a (Suc n)) = set (array_addrs a n) \<union> {(a :: ('a::mem_type) ptr) +\<^sub>p int n}"
    (is "?LHS a n = ?RHS a n")
proof (induct n arbitrary: a)
  fix a
  show "?LHS a 0 = ?RHS a 0"
    by clarsimp
next
  fix a n
  assume induct: "\<And>a. ?LHS a n = ?RHS a n"
  show "?LHS a (Suc n) = ?RHS a (Suc n)"
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (subst induct [where a="a +\<^sub>p 1"])
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (clarsimp simp: CTypesDefs.ptr_add_def field_simps insert_commute)
  done
qed

(* Alternative representation of the set of array elements. *)
lemma set_array_addrs:
  "set (array_addrs (p :: ('a::mem_type) ptr) n)
           = {x. \<exists>k. x = p +\<^sub>p int k \<and> k < n }"
  apply (induct n arbitrary: p)
   apply (clarsimp simp: not_less)
  apply (subst set_array_addrs_unfold_last)
  apply atomize
  apply (drule_tac x=p in spec)
  apply (erule ssubst)
  apply (rule set_eqI)
  apply (rule iffI)
   apply clarsimp
   apply (erule disjE)
    apply clarsimp
    apply force
   apply force
  apply clarsimp
  apply (drule_tac x=k in spec)
  apply (clarsimp simp: not_less)
  apply (subgoal_tac "k = n")
   apply clarsimp
  apply clarsimp
  done

end


(*
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Correctness of the LBV\<close>

theory LBVCorrect
imports LBVSpec Typing_Framework_1
begin

locale lbvs = lbv +
  fixes s\<^sub>0  :: 'a
  fixes c   :: "'a list"
  fixes ins :: "'b list"
  fixes \<tau>s  :: "'a list"
  defines phi_def:
  "\<tau>s \<equiv> map (\<lambda>pc. if c!pc = \<bottom> then wtl (take pc ins) c 0 s\<^sub>0 else c!pc)
       [0..<size ins]"

  assumes bounded: "bounded step (size ins)"
  assumes cert: "cert_ok c (size ins) \<top> \<bottom> A"
  assumes pres: "pres_type step (size ins) A"

lemma (in lbvs) phi_None [intro?]:
  "\<lbrakk> pc < size ins; c!pc = \<bottom> \<rbrakk> \<Longrightarrow> \<tau>s!pc = wtl (take pc ins) c 0 s\<^sub>0"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_Some [intro?]:
  "\<lbrakk> pc < size ins; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> \<tau>s!pc = c!pc"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) phi_len [simp]: "size \<tau>s = size ins"
(*<*) by (simp add: phi_def) (*>*)

lemma (in lbvs) wtl_suc_pc:
  assumes all: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes pc:  "pc+1 < size ins"
  assumes sA: "s\<^sub>0 \<in> A"
  shows "wtl (take (pc+1) ins) c 0 s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!(pc+1)"
(*<*)
proof -
  from all pc
  have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s\<^sub>0) \<noteq> T" by (rule wtl_all)
  with pc show ?thesis using sA pres cert all wtl_pres by (simp add: phi_def wtc split: if_split_asm)
qed
(*>*)

lemma (in lbvs) wtl_stable:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes s\<^sub>0:  "s\<^sub>0 \<in> A" and  pc:  "pc < size ins"
  shows "stable r step \<tau>s pc"
(*<*)
proof (unfold stable_def, clarify)
  fix pc' s' assume step: "(pc',s') \<in> set (step pc (\<tau>s ! pc))"
                      (is "(pc',s') \<in> set (?step pc)")

  from bounded pc step have pc': "pc' < size ins" by (rule boundedD)

  have tkpc: "wtl (take pc ins) c 0 s\<^sub>0 \<noteq> \<top>" (is "?s\<^sub>1 \<noteq> _") using wtl by (rule wtl_take)
  have s\<^sub>2: "wtl (take (pc+1) ins) c 0 s\<^sub>0 \<noteq> \<top>" (is "?s\<^sub>2 \<noteq> _") using wtl by (rule wtl_take)

  from wtl pc have wt_s\<^sub>1: "wtc c pc ?s\<^sub>1 \<noteq> \<top>" by (rule wtl_all)

  have c_Some: "\<forall>pc t. pc < size ins \<longrightarrow> c!pc \<noteq> \<bottom> \<longrightarrow> \<tau>s!pc = c!pc"
    by (simp add: phi_def)
  have c_None: "c!pc = \<bottom> \<Longrightarrow> \<tau>s!pc = ?s\<^sub>1" using pc ..

  from wt_s\<^sub>1 pc c_None c_Some
  have inst: "wtc c pc ?s\<^sub>1  = wti c pc (\<tau>s!pc)"
    by (simp add: wtc split: if_split_asm)

  have "?s\<^sub>1 \<in> A" using pres cert s\<^sub>0 wtl pc by (rule wtl_pres)
  with pc c_Some cert c_None
  have "\<tau>s!pc \<in> A" by (cases "c!pc = \<bottom>") (auto dest: cert_okD1)
  with pc pres
  have step_in_A: "snd`set (?step pc) \<subseteq> A" by (auto dest: pres_typeD2)
  then have inA1: "s' \<in> A" using step by auto

  show "s' \<sqsubseteq>\<^sub>r \<tau>s!pc'"
  proof (cases "pc' = pc+1")
    case True
    with pc' cert
    have cert_in_A: "c!(pc+1) \<in> A" by (auto dest: cert_okD1)
    from True pc' have pc1: "pc+1 < size ins" by simp
    with pres cert s\<^sub>0 wtl have inA2: "wtl (take (pc + 1) ins) c 0 s\<^sub>0 \<in> A" by (auto dest:wtl_pres)

    have c_None': "c!(pc +1)= \<bottom> \<Longrightarrow> \<tau>s!(pc + 1)= ?s\<^sub>2" using pc1 ..
    have "?s\<^sub>2 \<in> A" using pres cert s\<^sub>0 wtl pc1 by (rule wtl_pres)
    with pc1 c_Some cert c_None'
    have inA3: "\<tau>s!(pc+1) \<in> A" by (cases "c!(pc+1) = \<bottom>") (auto dest: cert_okD1)

    from pc1 tkpc have "?s\<^sub>2 = wtc c pc ?s\<^sub>1" by - (rule wtl_Suc)
    with inst
    have merge: "?s\<^sub>2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
    also from s\<^sub>2 merge have "\<dots> \<noteq> \<top>" (is "?merge \<noteq> _") by simp
    with cert_in_A step_in_A
    have "?merge = (map snd [(p',t') \<leftarrow> ?step pc. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!(pc+1))"
      by (rule merge_not_top_s)
    finally have "s' \<sqsubseteq>\<^sub>r ?s\<^sub>2" using step_in_A cert_in_A True step
      by (auto intro: pp_ub1')
    also from wtl pc1 have "?s\<^sub>2 \<sqsubseteq>\<^sub>r \<tau>s!(pc+1)" using s\<^sub>0 by (auto dest: wtl_suc_pc)
    also note True [symmetric]
    finally show ?thesis  using inA1 inA2 inA3 by simp
  next
    case False
    from wt_s\<^sub>1 inst
    have "merge c pc (?step pc) (c!(pc+1)) \<noteq> \<top>" by (simp add: wti)
    with step_in_A have "\<forall>(pc', s')\<in>set (?step pc). pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'"
      by - (rule merge_not_top)
    with step False  have ok: "s' \<sqsubseteq>\<^sub>r c!pc'" by blast
    moreover from ok have "c!pc' = \<bottom> \<Longrightarrow> s' = \<bottom>" using inA1 by simp
    moreover from c_Some pc'  have "c!pc' \<noteq> \<bottom> \<Longrightarrow> \<tau>s!pc' = c!pc'" by auto
    ultimately show ?thesis by (cases "c!pc' = \<bottom>") auto
  qed
qed
(*>*)

lemma (in lbvs) phi_not_top:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and pc:  "pc < size ins"
  shows "\<tau>s!pc \<noteq> \<top>"
(*<*)
proof (cases "c!pc = \<bottom>")
  case False with pc
  have "\<tau>s!pc = c!pc" ..
  also from cert pc have "\<dots> \<noteq> \<top>" by (rule cert_okD4)
  finally show ?thesis .
next
  case True with pc
  have "\<tau>s!pc = wtl (take pc ins) c 0 s\<^sub>0" ..
  also from wtl have "\<dots> \<noteq> \<top>" by (rule wtl_take)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvs) phi_in_A:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and s\<^sub>0: "s\<^sub>0 \<in> A"
  shows "\<tau>s \<in> nlists (size ins) A"
(*<*)
proof -
  { fix x assume "x \<in> set \<tau>s"
    then obtain xs ys where "\<tau>s = xs @ x # ys"
      by (auto simp add: in_set_conv_decomp)
    then obtain pc where pc: "pc < size \<tau>s" and x: "\<tau>s!pc = x"
      by (simp add: that [of "size xs"] nth_append)

    from pres cert wtl s\<^sub>0 pc
    have "wtl (take pc ins) c 0 s\<^sub>0 \<in> A" by (auto intro!: wtl_pres)
    moreover
    from pc have "pc < size ins" by simp
    with cert have "c!pc \<in> A" ..
    ultimately
    have "\<tau>s!pc \<in> A" using pc by (simp add: phi_def)
    hence "x \<in> A" using x by simp
  }
  hence "set \<tau>s \<subseteq> A" ..
  thus ?thesis by (unfold nlists_def) simp
qed
(*>*)

lemma (in lbvs) phi0:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>" and 0: "0 < size ins" and s\<^sub>0: "s\<^sub>0 \<in> A"
  shows "s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof (cases "c!0 = \<bottom>")
  case True
  with 0 have "\<tau>s!0 = wtl (take 0 ins) c 0 s\<^sub>0" ..
  moreover have "wtl (take 0 ins) c 0 s\<^sub>0 = s\<^sub>0" by simp
  ultimately have "\<tau>s!0 = s\<^sub>0" by simp
  thus ?thesis using s\<^sub>0 by simp
next
  case False
  with 0 have "\<tau>s!0 = c!0" ..
  moreover
  have "wtl (take 1 ins) c 0 s\<^sub>0 \<noteq> \<top>" using wtl by (rule wtl_take)
  with 0 False
  have "s\<^sub>0 \<sqsubseteq>\<^sub>r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
  ultimately
  show ?thesis by simp
qed
(*>*)

theorem (in lbvs) wtl_sound_strong:
  assumes wtl: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes s\<^sub>0: "s\<^sub>0 \<in> A" and ins: "0 < size ins"
  shows "\<exists>\<tau>s \<in> nlists (size ins) A. wt_step r \<top> step \<tau>s \<and> s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof -
  have "\<tau>s \<in> nlists (size ins) A" using wtl s\<^sub>0 by (rule phi_in_A)
  moreover
  have "wt_step r \<top> step \<tau>s"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < size \<tau>s"
    then obtain pc: "pc < size ins" by simp
    with wtl show "\<tau>s!pc \<noteq> \<top>" by (rule phi_not_top)
    from wtl s\<^sub>0 and pc show "stable r step \<tau>s pc" by (rule wtl_stable)
  qed
  moreover from wtl ins have "s\<^sub>0 \<sqsubseteq>\<^sub>r \<tau>s!0" using s\<^sub>0  by (rule phi0)
  ultimately show ?thesis by fast
qed
(*>*)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Sep_Attribs
imports Separation_Algebra Sep_Tactic_Helpers
begin

text{* Beyond the tactics above, there is also a set of attributes implemented to make proving
       things in separation logic easier. These rules should be considered internals and are not
       intended for direct use. *}

lemma sep_curry_atomised: "\<lbrakk>(\<And>s. (P \<and>* Q) s \<longrightarrow> R s); P s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (clarsimp simp: sep_conj_sep_impl)

lemma sep_remove_pure_imp_sep_imp: "( P \<longrightarrow>* (\<lambda>s. P' \<longrightarrow> Q s)) s \<Longrightarrow> P' \<Longrightarrow> (P \<longrightarrow>* Q) s"
  by (clarsimp)

lemma sep_backward: "\<lbrakk>\<And>s. P s \<longrightarrow> (Q \<and>* T) s; (P \<and>* (Q \<longrightarrow>* R)) s \<rbrakk> \<Longrightarrow> (T \<and>* R) s"
  by (metis sep_conj_commute sep_conj_impl1 sep_mp_frame)

lemma sep_remove_conj: "\<lbrakk>(P \<and>* R) s ; Q\<rbrakk> \<Longrightarrow> ((\<lambda>s. P s \<and> Q) \<and>* R) s "
  apply (clarsimp)
  done

lemma curry: "(P \<longrightarrow> Q \<longrightarrow> R) \<Longrightarrow> (P \<and> Q) \<longrightarrow> R"
  apply (safe)
  done

ML {*
local
  fun atomize_thm ctxt thm = Conv.fconv_rule (Object_Logic.atomize ctxt) thm
  fun setup_simpset ctxt = put_simpset HOL_basic_ss ctxt addsimps [(sym OF [@{thm sep_conj_assoc}])]
  fun simp ctxt thm = simplify (setup_simpset ctxt) thm

  fun REPEAT_TRYOF_N _ thm2 0 = thm2
    | REPEAT_TRYOF_N thm1 thm2 n = REPEAT_TRYOF_N thm1 (thm1 OF [thm2]) (n-1)

  fun REPEAT_TRYOF'_N thm1 _    0 = thm1
    | REPEAT_TRYOF'_N thm1 thm2 n = REPEAT_TRYOF'_N (thm1 OF [thm2]) thm2 (n-1)

  fun attribute_thm ctxt thm  thm' =
    REPEAT_TRYOF_N @{thm sep_remove_pure_imp_sep_imp} (thm OF [atomize_thm ctxt thm']) (Thm.nprems_of thm' - 1)

  fun attribute_thm' thm ctxt thm' =
    thm OF [REPEAT_TRYOF_N @{thm curry} (thm' |> atomize_thm ctxt o simp ctxt) (Thm.nprems_of thm' - 1)]

in

(*
 By attributing a theorem with [sep_curry], we can now take a rule (A \<and>* B) \<Longrightarrow> C and turn it into A \<Longrightarrow> (B \<longrightarrow>* C)
*)

fun sep_curry_inner ctxt = attribute_thm ( ctxt) @{thm sep_curry_atomised}
val sep_curry = Thm.rule_attribute [] (fn ctxt => sep_curry_inner (Context.proof_of ctxt))

(*
 The attribute sep_back takes a rule of the form A \<Longrightarrow> B and returns a rule (A \<and>* (B \<longrightarrow>* R)) \<Longrightarrow> R.
 The R then matches with any conclusion. If the theorem is of form (A \<and>* B) \<Longrightarrow> C, it is advised to
 use sep_curry on the theorem first, and then sep_back. This aids sep_cancel in simplifying the result.
*)

fun backward ctxt thm =
  REPEAT_TRYOF'_N (attribute_thm' @{thm sep_backward} ctxt thm) @{thm sep_remove_conj} (Thm.nprems_of thm - 1)

fun backward' ctxt thm = backward (Context.proof_of ctxt) thm

val sep_backward = Thm.rule_attribute [] (backward')

end
*}

attribute_setup sep_curry =  {* Scan.succeed sep_curry *}
attribute_setup sep_backward =  {* Scan.succeed sep_backward *}

end


theory ResMapDisj
  imports ResMap AltNormEnv
begin

lemma lift_sub_use_env: "\<lbrakk> sub_use_env s r_s \<rbrakk> \<Longrightarrow> sub_use_env s (lift_use_env r_s r)"
  apply (simp add: sub_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

    (* strong disjointness *)

definition strong_disj_use_env where
  "strong_disj_use_env r_x r_s = (\<forall> x. r_x x = NoPerm \<or> r_s x = NoPerm)"

lemma empty_strong_disj_use_env1: "strong_disj_use_env empty_use_env r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: empty_use_env_def)
  done

lemma empty_strong_disj_use_env2: "strong_disj_use_env r_s empty_use_env"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: empty_use_env_def)
  done

lemma comm_strong_disj_use_env: "\<lbrakk> strong_disj_use_env r_s r_x \<rbrakk> \<Longrightarrow> strong_disj_use_env r_x r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  done

lemma strong_disj_leq_use_env1: "\<lbrakk> strong_disj_use_env r_s r_ex; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env r_x r_ex"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma strong_disj_leq_use_env2: "\<lbrakk> strong_disj_use_env r_ex r_s; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env r_ex r_x"
  apply (rule_tac comm_strong_disj_use_env)
  apply (rule_tac r_s="r_s" in strong_disj_leq_use_env1)
   apply (rule_tac comm_strong_disj_use_env)
   apply (auto)
  done

lemma reduce_strong_disj_use_env: "\<lbrakk> disj_use_env r_s r_x; strong_use_env r_x \<rbrakk> \<Longrightarrow> strong_disj_use_env r_s r_x"
  apply (simp add: disj_use_env_def)
  apply (simp add: strong_use_env_def)
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma add_strong_disj_use_env: "\<lbrakk> strong_disj_use_env r_x r_s; r_s x = NoPerm \<rbrakk> \<Longrightarrow> strong_disj_use_env (add_use_env r_x x r) r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (auto)
  apply (simp add: add_use_env_def)
  apply (auto)
  done

lemma diff_strong_disj_use_env: "\<lbrakk> strong_use_env r_x \<rbrakk> \<Longrightarrow> strong_disj_use_env (diff_use_env r_s r_x) r_x"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: strong_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma strong_disj_comp_use_env1: "\<lbrakk> strong_disj_use_env r_ex r_x; strong_disj_use_env r_ex r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env r_ex (comp_use_env r_x r_s)"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (auto)
  done

lemma strong_disj_comp_use_env2: "\<lbrakk> strong_disj_use_env r_x r_ex; strong_disj_use_env r_s r_ex \<rbrakk> \<Longrightarrow> strong_disj_use_env (comp_use_env r_x r_s) r_ex"
  apply (rule_tac comm_strong_disj_use_env)
  apply (rule_tac strong_disj_comp_use_env1)
   apply (simp_all add: comm_strong_disj_use_env)
  done

    (* ### NEW DISJOINTNESS *)

definition disj_nres_map where
  "disj_nres_map rs_map = (\<forall> x y. x \<noteq> y \<longrightarrow> strong_disj_use_env (nres_lookup rs_map x) (nres_lookup rs_map y))"

definition sep_nres_map where
  "sep_nres_map r_s rs_map = (\<forall> x. strong_disj_use_env r_s (nres_lookup rs_map x))"

lemma add_sep_nres_map: "\<lbrakk> sep_nres_map r_x rs_map; strong_disj_use_env r_x r_s \<rbrakk> \<Longrightarrow> sep_nres_map r_x (add_env rs_map x r_s)"
  apply (simp add: sep_nres_map_def)
  apply (simp add: nres_lookup_def)
  apply (simp add: add_env_def)
  done

lemma leq_sep_nres_map: "\<lbrakk> leq_use_env r_x r_s; sep_nres_map r_s rs_map \<rbrakk> \<Longrightarrow> sep_nres_map r_x rs_map"
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (rule_tac r_s="r_s" in strong_disj_leq_use_env1)
   apply (auto)
  done

lemma comp_sep_nres_map: "\<lbrakk> sep_nres_map r_s rs_map; sep_nres_map r_x rs_map \<rbrakk> \<Longrightarrow> sep_nres_map (comp_use_env r_s r_x) rs_map"
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (rule_tac strong_disj_comp_use_env2)
   apply (auto)
  done

lemma disj_add_nres_map: "\<lbrakk> disj_nres_map rs_map;
  sep_nres_map r_s (rem_env rs_map x) \<rbrakk> \<Longrightarrow> disj_nres_map (add_env rs_map x r_s)"
  apply (simp add: disj_nres_map_def)
  apply (auto)
  apply (case_tac "x = xa")
   apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" and y="y" in nres_add_diff)
    apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (auto)
    apply (simp add: sep_nres_map_def)
   apply (erule_tac x="x" in allE)
   apply (erule_tac x="y" in allE)
   apply (cut_tac rs_map="rs_map" and x="x" and y="y" in nres_rem_diff)
    apply (auto)
  apply (case_tac "x = y")
   apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" and y="xa" in nres_add_diff)
    apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (auto)
   apply (rule_tac comm_strong_disj_use_env)
   apply (simp add: sep_nres_map_def)
   apply (erule_tac x="x" in allE)
   apply (erule_tac x="xa" in allE)
   apply (cut_tac rs_map="rs_map" and x="x" and y="xa" in nres_rem_diff)
    apply (auto)
  apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" and y="xa" in nres_add_diff)
  apply (auto)
  apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" and y="y" in nres_add_diff)
  apply (auto)
  done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory MultByAdd
imports
  "AutoCorres.AutoCorres"
begin

(* Parse the input file. *)
external_file "mult_by_add.c"
install_C_file "mult_by_add.c"

(* Abstract the input file. *)
autocorres [ ts_force nondet = mult_by_add ] "mult_by_add.c"

context mult_by_add begin

(*
 * Prove the function returns the correct result, and (simultaneously)
 * does not fail and terminates.
 *)
lemma "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  (* Unfold function definition. *)
  apply (clarsimp simp: mult_by_add'_def)

  (* Annotate while loop with an invariant and measure. *)
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', r) s. (a' * b) + r = (a * b)"
       and M="\<lambda>((a', _), s). unat a'"])

  (* Run "wp" weakest precondition tactic, and solve verification *
   * conditions generated by it. *)
  apply wp
     apply (simp add: field_simps)
    apply unat_arith
   apply (simp add: split_def word_neq_0_conv[symmetric])
  apply (simp add: split_def | wp)+
  done

(*
 * Equivalent partial-correctness proof using Simpl framework.
 *)
lemma "\<Gamma> \<turnstile> {s. s = t} \<acute>ret__unsigned :== CALL mult_by_add(\<acute>a, \<acute>b) \<lbrace> (\<acute>ret__unsigned = \<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
  (* Unfold the body. *)
  apply vcg_step
   defer

   (* Annotate the while loop with an invariant and variant. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> (\<acute>a * \<acute>b + \<acute>result) = (\<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
     and V="measure (\<lambda>s. unat (a_' s))"])

  (* Solve the remaining conditions. *)
   apply vcg
   apply (fastforce intro: unat_mono simp: gt0_iff_gem1 field_simps less_1_simp scast_id)+
  done

end

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Authors: David Cock - David.Cock@nicta.com.au, Thomas Sewell - Thomas.Sewell@nicta.com.au *)

section "Loop Termination"

theory Termination imports Embedding StructuredReasoning Loops begin

text_raw \<open>\label{s:termination}\<close>

text \<open>Termination for loops can be shown by classical means (using a variant, or a measure
function), or by probabilistic means: We only need that the loop terminates \emph{with probability
one}.\<close>

subsection \<open>Trivial Termination\<close>

text \<open>A maximal transformer (program) doesn't affect termination. This is
  essentially saying that such a program doesn't abort (or diverge).\<close>
lemma maximal_Seq_term:
  fixes r::"'s prog" and s::"'s prog"
  assumes mr: "maximal (wp r)"
      and ws: "well_def s"
      and ts: "(\<lambda>s. 1) \<tturnstile> wp s (\<lambda>s. 1)"
  shows "(\<lambda>s. 1) \<tturnstile> wp (r ;; s) (\<lambda>s. 1)"
proof -
  note hs = well_def_wp_healthy[OF ws]
  have "wp s (\<lambda>s. 1) = (\<lambda>s. 1)"
  proof(rule antisym)
    show "(\<lambda>s. 1) \<tturnstile> wp s (\<lambda>s. 1)" by(rule ts)
    have "bounded_by 1 (wp s (\<lambda>s. 1))"
      by(auto intro!:healthy_bounded_byD[OF hs])
    thus "wp s (\<lambda>s. 1) \<tturnstile> (\<lambda>s. 1)" by(auto intro!:le_funI)
  qed
  with mr show ?thesis
    by(simp add:wp_eval embed_bool_def maximalD)
qed

text \<open>From any state where the guard does not hold, a loop terminates
  in a single step.\<close>
lemma term_onestep:
  assumes wb: "well_def body"
  shows "\<guillemotleft>\<N> G\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
proof(rule le_funI)
  note hb = well_def_wp_healthy[OF wb]
  fix s
  show "\<guillemotleft>\<N> G\<guillemotright> s \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
  proof(cases "G s", simp_all add:wp_loop_nguard hb)
    from hb have "sound (wp do G \<longrightarrow> body od (\<lambda>s. 1))"
      by(auto intro:healthy_sound[OF healthy_wp_loop])
    thus "0 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s" by(auto)
  qed
qed

subsection \<open>Classical Termination\<close>

text \<open>The first non-trivial termination result is quite standard: If we can provide a
natural-number-valued measure, that decreases on every iteration, and implies termination on
reaching zero, the loop terminates.\<close>

lemma loop_term_nat_measure_noinv:
  fixes m :: "'s \<Rightarrow> nat" and body :: "'s prog"
  assumes wb: "well_def body"
  and guard: "\<And>s. m s = 0 \<longrightarrow> \<not> G s"
  and variant: "\<And>n. \<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> \<tturnstile> wp body \<guillemotleft>\<lambda>s. m s = n\<guillemotright>"
  shows "\<lambda>s. 1 \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
proof -
  note hb = well_def_wp_healthy[OF wb]
  have "\<And>n. (\<forall>s. m s = n \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s)"
  proof(induct_tac n)
    fix n
    show "\<forall>s. m s = 0 \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
    proof(clarify)
      fix s
      assume "m s = 0"
      with guard have "\<not> G s" by(blast)
      with hb show "1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
        by(simp add:wp_loop_nguard)
    qed
    assume IH: "\<forall>s. m s = n \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
    hence IH': "\<forall>s. m s = n \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      by(simp add:embed_bool_def)
    have "\<forall>s. m s = Suc n \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
    proof(intro fold_premise healthy_intros hb, rule le_funI)
      fix s
      show "\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> s \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      proof(cases "G s")
        case False
        hence "1 = \<guillemotleft>\<N> G\<guillemotright> s" by(auto)
        also from wb have "... \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
          by(rule le_funD[OF term_onestep])
        finally show ?thesis by(simp add:embed_bool_def)
      next
        case True note G = this
        from IH' have "\<guillemotleft>\<lambda>s. m s = n\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright>"
          by(blast intro:use_premise healthy_intros hb)
        with variant wb
        have "\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> \<tturnstile> wp (body ;; do G \<longrightarrow> body od) \<guillemotleft>\<lambda>s. True\<guillemotright>"
          by(blast intro:wp_Seq wd_intros)
        hence "\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> s \<le> wp (body ;; do G \<longrightarrow> body od) \<guillemotleft>\<lambda>s. True\<guillemotright> s"
          by(auto)
        also from hb G have "... = wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
          by(simp add:wp_loop_guard)
        finally show ?thesis .
      qed
    qed
    thus "\<forall>s. m s = Suc n \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
      by(simp add:embed_bool_def)
  qed
  thus ?thesis by(auto)
qed

text \<open>This version allows progress to depend on an invariant. Termination is then determined by
the invariant's value in the initial state.\<close>
lemma loop_term_nat_measure:
  fixes m :: "'s \<Rightarrow> nat" and body :: "'s prog"
  assumes wb:  "well_def body"
  and guard:   "\<And>s. m s = 0 \<longrightarrow> \<not> G s"
  and variant: "\<And>n. \<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && \<guillemotleft>I\<guillemotright> \<tturnstile> wp body \<guillemotleft>\<lambda>s. m s = n\<guillemotright>"
  and inv:     "wp_inv G body \<guillemotleft>I\<guillemotright>"
  shows "\<guillemotleft>I\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
proof -
  note hb = well_def_wp_healthy[OF wb]
  note scb = sublinear_sub_conj[OF well_def_wp_sublinear, OF wb]
  have "\<guillemotleft>I\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright>"
  proof(rule use_premise, intro healthy_intros hb)
    fix s
    have "\<And>n. (\<forall>s. m s = n \<and> I s \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s)"
    proof(induct_tac n)
      fix n
      show "\<forall>s. m s = 0 \<and> I s \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      proof(clarify)
        fix s
        assume "m s = 0"
        with guard have "\<not> G s" by(blast)
        with hb show "1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
          by(simp add:wp_loop_nguard)
      qed
      assume IH: "\<forall>s. m s = n \<and> I s \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      show "\<forall>s. m s = Suc n \<and> I s \<longrightarrow> 1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      proof(intro fold_premise healthy_intros hb le_funI)
        fix s
        show "\<guillemotleft>\<lambda>s. m s = Suc n \<and> I s\<guillemotright> s \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
        proof(cases "G s")
          case False with hb show ?thesis
            by(simp add:wp_loop_nguard)
        next
          case True note G = this
          have "\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && \<guillemotleft>I\<guillemotright> && \<guillemotleft>G\<guillemotright> =
                \<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && (\<guillemotleft>I\<guillemotright> && \<guillemotleft>I\<guillemotright>) && \<guillemotleft>G\<guillemotright>"
            by(simp)
          also have "... = (\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && \<guillemotleft>I\<guillemotright>) && (\<guillemotleft>I\<guillemotright> && \<guillemotleft>G\<guillemotright>)"
            by(simp add:exp_conj_assoc exp_conj_unitary del:exp_conj_idem)
          also have "... = (\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && \<guillemotleft>I\<guillemotright>) && (\<guillemotleft>G\<guillemotright> && \<guillemotleft>I\<guillemotright>)"
            by(simp only:exp_conj_comm)
          also {
            from inv hb have "\<guillemotleft>G\<guillemotright> && \<guillemotleft>I\<guillemotright> \<tturnstile> wp body \<guillemotleft>I\<guillemotright>"
              by(rule wp_inv_stdD)
            with variant
            have "(\<guillemotleft>\<lambda>s. m s = Suc n\<guillemotright> && \<guillemotleft>I\<guillemotright>) && (\<guillemotleft>G\<guillemotright> && \<guillemotleft>I\<guillemotright>) \<tturnstile>
                  wp body \<guillemotleft>\<lambda>s. m s = n\<guillemotright> && wp body \<guillemotleft>I\<guillemotright>"
              by(rule entails_frame)
          }
          also from scb
          have "wp body \<guillemotleft>\<lambda>s. m s = n\<guillemotright> && wp body \<guillemotleft>I\<guillemotright> \<tturnstile>
                wp body (\<guillemotleft>\<lambda>s. m s = n\<guillemotright> && \<guillemotleft>I\<guillemotright>)"
            by(blast)
          finally have "\<guillemotleft>\<lambda>s. m s = Suc n \<guillemotright> && \<guillemotleft> I \<guillemotright> && \<guillemotleft> G \<guillemotright> \<tturnstile>
                        wp body (\<guillemotleft> \<lambda>s. m s = n \<guillemotright> && \<guillemotleft> I \<guillemotright>)" .
          moreover {
            from IH have "\<guillemotleft>\<lambda>s. m s = n \<and> I s\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright>"
              by(blast intro:use_premise healthy_intros hb)
            hence "\<guillemotleft>\<lambda>s. m s = n\<guillemotright> && \<guillemotleft>I\<guillemotright> \<tturnstile> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright>"
              by(simp add:exp_conj_std_split)
          }
          ultimately
          have "\<guillemotleft>\<lambda>s. m s = Suc n \<guillemotright> && \<guillemotleft> I \<guillemotright> && \<guillemotleft> G \<guillemotright> \<tturnstile>
                wp (body ;; do G \<longrightarrow> body od) \<guillemotleft>\<lambda>s. True\<guillemotright>"
            using wb by(blast intro:wp_Seq wd_intros)
          hence "(\<guillemotleft>\<lambda>s. m s = Suc n \<and> I s\<guillemotright> && \<guillemotleft> G \<guillemotright>) s \<le>
                 wp (body ;; do G \<longrightarrow> body od) \<guillemotleft>\<lambda>s. True\<guillemotright> s"
            by(auto simp:exp_conj_std_split)
          with G have "\<guillemotleft>\<lambda>s. m s = Suc n \<and> I s\<guillemotright> s \<le>
                       wp (body ;; do G \<longrightarrow> body od) \<guillemotleft>\<lambda>s. True\<guillemotright> s"
            by(simp add:exp_conj_def)
          also from hb G have "... = wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
            by(simp add:wp_loop_guard)
          finally show ?thesis .
        qed
      qed
    qed
    moreover assume "I s"
    ultimately show "1 \<le> wp do G \<longrightarrow> body od \<guillemotleft>\<lambda>s. True\<guillemotright> s"
      by(auto)
  qed
  thus ?thesis by(simp add:embed_bool_def)
qed

subsection \<open>Probabilistic Termination\<close>

text \<open>Any loop that has a non-zero chance of terminating after each step terminates with
probability 1.\<close>

lemma termination_0_1:
  fixes body :: "'s prog"
  assumes wb: "well_def body"
      \<comment> \<open>The loop terminates in one step with nonzero probability\<close>
      and onestep: "(\<lambda>s. p) \<tturnstile> wp body \<guillemotleft>\<N> G\<guillemotright>"
      and nzp:     "0 < p"
      \<comment> \<open>The body is maximal i.e.~it terminates absolutely.\<close>
      and mb:      "maximal (wp body)"
  shows "\<lambda>s. 1 \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
proof -
  note hb = well_def_wp_healthy[OF wb]
  note sb = healthy_scalingD[OF hb]
  note sab = sublinear_subadd[OF well_def_wp_sublinear, OF wb, OF healthy_feasibleD, OF hb]

  from hb have hloop: "healthy (wp do G \<longrightarrow> body od)"
    by(rule healthy_intros)
  hence swp: "sound (wp do G \<longrightarrow> body od (\<lambda>s. 1))" by(blast)

  txt \<open>@{term p} is no greater than $1$, by feasibility.\<close>
  from onestep have onestep': "\<And>s. p \<le> wp body \<guillemotleft>\<N> G\<guillemotright> s" by(auto)
  also {
    from hb have "unitary (wp body \<guillemotleft>\<N> G\<guillemotright>)" by(auto)
    hence "\<And>s. wp body \<guillemotleft>\<N> G\<guillemotright> s \<le> 1" by(auto)
  }
  finally have p1: "p \<le> 1" .

  txt \<open>This is the crux of the proof: that given a lower bound below $1$, we can find another,
    higher one.\<close>
  have new_bound: "\<And>k. 0 \<le> k \<Longrightarrow> k \<le> 1 \<Longrightarrow> (\<lambda>s. k) \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1) \<Longrightarrow>
            (\<lambda>s. p * (1-k) + k) \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
  proof(rule le_funI)
    fix k s
    assume X: "\<lambda>s. k \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)"
       and k0: "0 \<le> k" and k1: "k \<le> 1"

    from k1 have nz1k: "0 \<le> 1 - k" by(auto)
    with p1 have "p * (1-k) + k \<le> 1 * (1-k) + k"
      by(blast intro:mult_right_mono add_mono)
    hence "p * (1 - k) + k \<le> 1"
      by(simp)
    txt \<open>The new bound is @{term "p * (1-k) + k"}.\<close>
    hence "p * (1-k) + k \<le> \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (p * (1-k) + k)"
      by(cases "G s", simp_all)
    txt \<open>By the one-step termination assumption:\<close>
    also from onestep' nz1k
    have "... \<le> \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body \<guillemotleft>\<N> G\<guillemotright> s * (1-k) + k)"
      by (simp add: mult_right_mono ordered_comm_semiring_class.comm_mult_left_mono)
    txt \<open>By scaling:\<close>
    also from nz1k
    have "... =  \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s * (1-k)) s + k)"
      by(simp add:right_scalingD[OF sb])
    txt \<open>By the maximality (termination) of the loop body:\<close>
    also from mb k0
    have "... =  \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s * (1-k)) s + wp body (\<lambda>s. k) s)"
      by(simp add:maximalD)
    txt \<open>By sub-additivity of the loop body:\<close>
    also from k0 nz1k
    have "... \<le> \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s * (1-k) + k) s)"
      by(auto intro!:add_left_mono mult_left_mono sub_addD[OF sab] sound_intros)
    also
    have "... = \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * k) s)"
      by(simp add:negate_embed algebra_simps)
    txt \<open>By monotonicity of the loop body, and that @{term k} is a lower bound:\<close>
    also from k0 hloop le_funD[OF X]
    have "... \<le> \<guillemotleft>\<N> G\<guillemotright> s +
      \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp do G \<longrightarrow> body od (\<lambda>s. 1) s) s)"
      by(iprover intro:add_left_mono mult_left_mono le_funI embed_ge_0
                       le_funD[OF mono_transD, OF healthy_monoD, OF hb]
                       sound_sum standard_sound sound_intros swp)
    txt \<open>Unrolling the loop once and simplifying:\<close>
    also {
      have "\<And>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp body (wp do G \<longrightarrow> body od (\<lambda>s. 1)) s =
        \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (\<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp body (wp do G \<longrightarrow> body od (\<lambda>s. 1)) s)"
        by(simp only:distrib_left mult.assoc[symmetric] embed_bool_idem embed_bool_cancel)
      also have "\<And>s. ... s = \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
        by(simp add:fun_cong[OF wp_loop_unfold[symmetric, where P="\<lambda>s. 1", simplified, OF hb]])
      finally have X: "\<And>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp body (wp do G \<longrightarrow> body od (\<lambda>s. 1)) s =
        \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * wp do G \<longrightarrow> body od (\<lambda>s. 1) s" .
      have "\<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s *
              wp do G \<longrightarrow> body od (\<lambda>s. 1) s) s) =
            \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s *
              wp body (wp do G \<longrightarrow> body od (\<lambda>s. 1)) s) s)"
        by(simp only:X)
    }
    txt \<open>Lastly, by folding two loop iterations:\<close>
    also
    have "\<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s * (wp body (\<lambda>s. \<guillemotleft>\<N> G\<guillemotright> s + \<guillemotleft>G\<guillemotright> s *
            wp body (wp do G \<longrightarrow> body od (\<lambda>s. 1)) s) s) =
          wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
      by(simp add:wp_loop_unfold[OF _ hb, where P="\<lambda>s. 1", simplified, symmetric]
                  fun_cong[OF wp_loop_unfold[OF _ hb, where P="\<lambda>s. 1", simplified, symmetric]])
    finally show "p * (1-k) + k \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s" .
  qed

  txt \<open>If the previous bound lay in $[0,1)$, the new bound is strictly greater.  This is where
    we appeal to the fact that @{term p} is nonzero.\<close>
  from nzp have inc: "\<And>k. 0 \<le> k \<Longrightarrow> k < 1 \<Longrightarrow> k < p * (1 - k) + k"
    by(auto intro:mult_pos_pos)

  txt \<open>The result follows by contradiction.\<close>
  show ?thesis
  proof(rule ccontr)
    txt \<open>If the loop does not terminate everywhere, then there must exist some state
      from which the probability of termination is strictly less than one.\<close>
    assume "\<not> ?thesis"
    hence "\<not> (\<forall>s. 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s)" by(auto)
    then obtain s where point: "\<not> 1 \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s" by(auto)

    let ?k = "Inf (range (wp do G \<longrightarrow> body od (\<lambda>s. 1)))"

    from hloop
    have Inflb: "\<And>s. ?k \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
      by(intro cInf_lower bdd_belowI, auto)
    also from point have "wp do G \<longrightarrow> body od (\<lambda>s. 1) s < 1" by(auto)
    txt \<open>Thus the least (infimum) probabilty of termination is strictly less than one.\<close>
    finally have k1: "?k < 1" .
    hence "?k \<le> 1" by(auto)
    moreover from hloop have k0: "0 \<le> ?k"
      by(intro cInf_greatest, auto)
    txt \<open>The infimum is, naturally, a lower bound.\<close>
    moreover from Inflb have "(\<lambda>s. ?k) \<tturnstile> wp do G \<longrightarrow> body od (\<lambda>s. 1)" by(auto)
    ultimately
    txt \<open>We can therefore use the previous result to find a new bound, \ldots\<close>
    have "\<And>s. p * (1 - ?k) + ?k \<le> wp do G \<longrightarrow> body od (\<lambda>s. 1) s"
      by(blast intro:le_funD[OF new_bound])
    txt \<open>\ldots which is lower than the infimum, by minimality, \ldots\<close>
    hence "p * (1 - ?k) + ?k \<le> ?k"
      by(blast intro:cInf_greatest)
    txt \<open>\ldots yet also strictly greater than it.\<close>
    moreover from k0 k1 have "?k < p * (1 - ?k) + ?k" by(rule inc)
    txt \<open>We thus have a contradiction.\<close>
    ultimately show False by(simp)
  qed
qed

end


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

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

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

  shows "\<tau>.(P) \<leadsto><Rel> \<tau>.(Q)"
proof(induct rule: simCases)
  case(Bound Q' a y)
  have "\<tau>.(Q) \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
  hence False by auto
  thus ?case by simp
next
  case(Input Q' a x)
  have "\<tau>.(Q) \<longmapsto>a<x> \<prec> Q'" by fact
  hence False by auto
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "\<tau>.(Q) \<longmapsto> \<alpha> \<prec> Q'" by fact
  thus ?case using PRelQ
  proof(induct rule: tauCases, auto simp add: pi.inject residual.inject)
    have "\<tau>.(P) \<Longrightarrow>\<^sub>l\<tau> \<prec> P" by(rule Weak_Late_Step_Semantics.Tau)
    moreover assume "(P, Q') \<in> Rel"
    ultimately show "\<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sub>l\<tau> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed
qed

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

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

  shows "a<x>.P \<leadsto><Rel> a<x>.Q"
proof -
  show ?thesis using Eqvt
  proof(induct rule: simCasesCont[of _ "(P, a, x, Q)"])
    case(Bound Q' b y)
    have "a<x>.Q \<longmapsto>b<\<nu>y> \<prec> Q'" by fact
    hence False by auto
    thus ?case by simp
  next
    case(Input Q' b y)
    have "y \<sharp> (P, a, x, Q)" by fact
    hence yFreshP: "(y::name) \<sharp> P" and yineqx: "y \<noteq> x" and "y \<noteq> a" and "y \<sharp> Q"
      by(simp add: fresh_prod)+
    have "a<x>.Q \<longmapsto>b<y> \<prec> Q'" by fact
    thus ?case using \<open>y \<noteq> a\<close> \<open>y \<noteq> x\<close> \<open>y \<sharp> Q\<close>
    proof(induct rule: inputCases, auto simp add: subject.inject)
      have "\<forall>u. \<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
      proof(rule allI)
        fix u
        have "a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> ([(x, y)] \<bullet> P)[y::=u]" (is "?goal")
        proof -
          from yFreshP have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(rule Agent.alphaInput)
          moreover have "a<y>.([(x, y)] \<bullet> P) \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> ([(x, y)] \<bullet> P)[y::=u]"
            by(rule Weak_Late_Step_Semantics.Input)
          ultimately show ?goal by(simp add: name_swap)
        qed

        moreover have "(([(x, y)] \<bullet> P)[y::=u], ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
        proof -
          from PRelQ have "(P[x::=u], Q[x::=u]) \<in> Rel" by auto
          with \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close> show ?thesis by(simp add: renaming)
        qed

        ultimately show "\<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
          by blast
      qed

      thus "\<exists>P''. \<forall>u. \<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel" by blast
    qed
  next
    case(Free Q' \<alpha>)
    have "a<x>.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    hence False by auto
    thus ?case by simp
  qed
qed

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

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

  shows "a{b}.P \<leadsto><Rel> a{b}.Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "a{b}.Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  hence False by auto
  thus ?case by simp
next
  case(Input Q' c x)
  have "a{b}.Q \<longmapsto>c<x> \<prec> Q'" by fact
  hence False by auto
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "a{b}.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case using PRelQ
  proof(induct rule: outputCases, auto simp add: pi.inject residual.inject)
    have "a{b}.P \<Longrightarrow>\<^sub>la[b] \<prec> P" by(rule Weak_Late_Step_Semantics.Output)
    moreover assume "(P, Q') \<in> Rel"
    ultimately show "\<exists>P'. a{b}.P \<Longrightarrow>\<^sub>la[b] \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed
qed

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

  shows "[a\<frown>b]P \<leadsto><Rel'> [a\<frown>b]Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "x \<sharp> [a\<frown>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto> c<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case cMatch
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lc<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>\<^sub>lc<\<nu>x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Match)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Input Q' c x)
  have "x \<sharp> [a\<frown>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto>c<x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case cMatch
    have "Q \<longmapsto> c<x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. [a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
        by blast
      from PTrans have "[a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Match)
      with P'RelQ' RelRel' show "\<exists>P'. [a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
        by blast
    qed
    thus ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "[a\<frown>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case cMatch
    have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.Match)
    with PRel RelRel' show ?case by blast
  qed
qed

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

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

  shows "[a\<noteq>b]P \<leadsto><Rel'> [a\<noteq>b]Q"
proof(cases "a=b")
  assume "a=b"
  thus ?thesis
    by(auto simp add: weakStepSimDef)
next
  assume aineqb: "a\<noteq>b"
  show ?thesis
  proof(induct rule: simCases)
    case(Bound Q' c x)
    have "x \<sharp> [a\<noteq>b]P" by fact
    hence xFreshP: "(x::name) \<sharp> P" by simp
    have "[a\<noteq>b]Q \<longmapsto> c<\<nu>x> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: mismatchCases)
      case cMismatch
      have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
      with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lc<\<nu>x> \<prec> P'"
                                     and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans aineqb have "[a\<noteq>b]P \<Longrightarrow>\<^sub>lc<\<nu>x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Mismatch)
      moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
      ultimately show ?case by blast
    qed
  next
    case(Input Q' c x)
    have "x \<sharp> [a\<noteq>b]P" by fact
    hence xFreshP: "(x::name) \<sharp> P" by simp
    have "[a\<noteq>b]Q \<longmapsto>c<x> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: mismatchCases)
      case cMismatch
      have "Q \<longmapsto> c<x> \<prec> Q'" by fact
      with PSimQ xFreshP obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
        by(blast dest: simE)
      have "\<forall>u. \<exists>P'. [a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
      proof(rule allI)
        fix u
        from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
          by blast
        from PTrans aineqb have "[a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Mismatch)
        with P'RelQ' RelRel' show "\<exists>P'. [a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
          by blast
      qed
      thus ?case by blast
    qed
  next
    case(Free Q' \<alpha>)
    have "[a\<noteq>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: mismatchCases)
      case cMismatch
      have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans \<open>a \<noteq> b\<close> have "[a\<noteq>b]P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.Mismatch)
      with PRel RelRel' show ?case by blast
    qed
  qed
qed

lemma sumCompose:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi
  and   T :: pi

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RSimT: "R \<leadsto><Rel> T"
  and     RelRel': "Rel \<subseteq> Rel'"

  shows "P \<oplus> R \<leadsto><Rel'> Q \<oplus> T"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "x \<sharp> P \<oplus> R" by fact
  hence xFreshP: "(x::name) \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
  have "Q \<oplus> T \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: sumCases)
    case cSum1
    have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
    with xFreshP PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "P \<oplus> R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Sum1)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  next
    case cSum2
    have "T \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
    with xFreshR RSimT obtain R' where RTrans: "R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> R'" and R'RelQ': "(R', Q') \<in> Rel"
      by(blast dest: simE)
    from RTrans have "P \<oplus> R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> R'" by(rule Weak_Late_Step_Semantics.Sum2)
    moreover from R'RelQ' RelRel' have "(R', Q') \<in> Rel'" by blast
    ultimately show ?thesis by blast
  qed
next
  case(Input Q' a x)
  have "x \<sharp> P \<oplus> R" by fact
  hence xFreshP: "(x::name) \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
  have "Q \<oplus> T \<longmapsto>a<x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: sumCases)
    case cSum1
    have "Q \<longmapsto>a<x> \<prec> Q'" by fact
    with xFreshP PSimQ obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<oplus> R \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                          and P'RelQ': "(P', Q'[x::=u]) \<in> Rel" by blast
      from PTrans have "P \<oplus> R \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Sum1)
      with P'RelQ' RelRel' show "\<exists>P'. P \<oplus> R \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
    qed
    thus ?case by blast
  next
    case cSum2
    have "T \<longmapsto>a<x> \<prec> Q'" by fact
    with xFreshR RSimT obtain R'' where L1: "\<forall>u. \<exists>R'. R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R' \<and> (R', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<oplus> R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain R' where RTrans: "R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R'"
                          and R'RelQ': "(R', Q'[x::=u]) \<in> Rel" by blast
      from RTrans have "P \<oplus> R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R'" by(rule Weak_Late_Step_Semantics.Sum2)
      with R'RelQ' RelRel' show  "\<exists>P'. P \<oplus> R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
    qed
    thus ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "Q \<oplus> T \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: sumCases)
    case cSum1
    have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "P \<oplus> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.Sum1)
    with RelRel' PRel show ?case by blast
  next
    case cSum2
    have "T \<longmapsto>\<alpha> \<prec> Q'" by fact
    with RSimT obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<alpha> \<prec> R'" and RRel: "(R', Q') \<in> Rel"
      by(blast dest: simE)
    from RTrans have "P \<oplus> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> R'" by(rule Weak_Late_Step_Semantics.Sum2)
    with RelRel' RRel show ?case by blast
  qed
qed

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

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

  shows "P \<oplus> R \<leadsto><Rel'> Q \<oplus> R"
proof -
  from Id have Refl: "R \<leadsto><Rel> R" by(rule reflexive)
  from PSimQ Refl RelRel' show ?thesis by(rule sumCompose)
qed

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

  assumes PSimQ:    "P \<leadsto><Rel> Q"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     Par:      "\<And>P Q R. (P, Q) \<in> Rel \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> Rel'"
  and     Res:      "\<And>P Q a. (P, Q) \<in> Rel' \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> Rel'"
  and     EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "P \<parallel> R \<leadsto><Rel'> Q \<parallel> R"
using EqvtRel'
proof(induct rule: simCasesCont[where C="(P, Q, R)"])
  case(Bound Q' a x)
  have "x \<sharp> (P, Q, R)" by fact
  hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" and "x \<sharp> Q" by simp+
  from \<open>Q \<parallel> R \<longmapsto> a<\<nu>x> \<prec> Q'\<close> \<open>x \<sharp> Q\<close> \<open>x \<sharp> R\<close> show ?case
  proof(induct rule: parCasesB)
    case(cPar1 Q')
    have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact

    from xFreshP PSimQ QTrans obtain P' where PTrans:"P \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Weak_Late_Step_Semantics.Par1B)
    moreover from P'RelQ' have "(P' \<parallel> R, Q' \<parallel> R) \<in> Rel'" by(rule Par)
    ultimately show ?case by blast
  next
    case(cPar2 R')
    have RTrans: "R \<longmapsto> a<\<nu>x> \<prec> R'" by fact
    hence "R \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> R'"
      by(auto simp add: weakTransition_def dest: Weak_Late_Step_Semantics.singleActionChain)
    with xFreshP xFreshR have ParTrans: "P \<parallel> R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P \<parallel> R'"
      by(blast intro: Weak_Late_Step_Semantics.Par2B)
    moreover from PRelQ  have "(P \<parallel> R', Q \<parallel>  R') \<in> Rel'" by(rule Par)
    ultimately show ?case by blast
  qed
next
  case(Input Q' a x)
  have "x \<sharp> (P, Q, R)" by fact
  hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" and "x \<sharp> Q" by simp+
  from \<open>Q \<parallel> R \<longmapsto>a<x> \<prec> Q'\<close> \<open>x \<sharp> Q\<close> \<open>x \<sharp> R\<close>
  show ?case
  proof(induct rule: parCasesB)
    case(cPar1 Q')
    have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" by fact
    from xFreshP PSimQ QTrans obtain P''
      where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u] \<parallel> R[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans:"P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                          and P'RelQ': "(P', Q'[x::=u]) \<in> Rel" by blast
      from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> (P' \<parallel> R)"
        by(rule Weak_Late_Step_Semantics.Par1B)
      moreover from P'RelQ'  have "(P' \<parallel> R, Q'[x::=u] \<parallel> R) \<in> Rel'"
        by(rule Par)
      ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u] \<parallel> (R[x::=u])) \<in> Rel'"
        using xFreshR
        by(force simp add: forget)
    qed
    thus ?case by force
  next
    case(cPar2 R')
    have RTrans: "R \<longmapsto>a<x> \<prec> R'" by fact
    have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R')\<rightarrow>a<x> \<prec> P' \<and> (P', Q \<parallel> R'[x::=u]) \<in> Rel'"
    proof
      fix u
      from RTrans have "R \<Longrightarrow>\<^sub>lu in R'\<rightarrow>a<x> \<prec> R'[x::=u]"
        by(rule Weak_Late_Step_Semantics.singleActionChain)
      hence "P \<parallel> R \<Longrightarrow>\<^sub>lu in P \<parallel> R'\<rightarrow>a<x> \<prec> P \<parallel> R'[x::=u]" using \<open>x \<sharp> P\<close>
        by(rule Weak_Late_Step_Semantics.Par2B)
      moreover from PRelQ have "(P \<parallel> R'[x::=u], Q \<parallel>  R'[x::=u]) \<in> Rel'" by(rule Par)
      ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R')\<rightarrow>a<x> \<prec> P' \<and>
                           (P', Q \<parallel> R'[x::=u]) \<in> Rel'" by blast
    qed
    thus ?case using \<open>x \<sharp> Q\<close> by(fastforce simp add: forget)
  qed
next
  case(Free QR' \<alpha>)
  have "Q \<parallel> R \<longmapsto> \<alpha> \<prec> QR'" by fact
  thus ?case
  proof(induct rule: parCasesF[of _ _ _ _ _ "(P, R)"])
    case(cPar1 Q')
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Late_Step_Semantics.Par1F)
    moreover from PRel have "(P' \<parallel> R, Q' \<parallel> R) \<in> Rel'" by(blast intro: Par)
    ultimately show ?case by blast
  next
    case(cPar2 R')
    have "R \<longmapsto> \<alpha> \<prec> R'" by fact
    hence "R \<Longrightarrow>\<^sub>l\<alpha> \<prec> R'"
      by(rule Weak_Late_Step_Semantics.singleActionChain)
    hence "P \<parallel> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> (P \<parallel> R')" by(rule Weak_Late_Step_Semantics.Par2F)
    moreover from PRelQ have "(P \<parallel> R', Q \<parallel> R') \<in> Rel'" by(blast intro: Par)
    ultimately show ?case by blast
  next
    case(cComm1 Q' R' a b x)
    have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" and RTrans: "R \<longmapsto> a[b] \<prec> R'" by fact+
    have "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" by(simp add: fresh_prod)

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

    from RTrans have "R \<Longrightarrow>\<^sub>la[b] \<prec> R'"
      by(rule Weak_Late_Step_Semantics.singleActionChain)

    with PTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Late_Step_Semantics.Comm1)
    moreover from P'RelQ' have "(P' \<parallel> R', Q'[x::=b] \<parallel> R') \<in> Rel'" by(rule Par)
    ultimately show ?case by blast
  next
    case(cComm2 Q' R' a b x)
    have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" and RTrans: "R \<longmapsto>a<x> \<prec> R'" by fact+
    have "x \<sharp> (P, R)" by fact
    hence xFreshR: "x \<sharp> R" by(simp add: fresh_prod)

    from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la[b] \<prec> P'"
                                  and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from RTrans have "R \<Longrightarrow>\<^sub>lb in R'\<rightarrow>a<x> \<prec> R'[x::=b]"
      by(rule Weak_Late_Step_Semantics.singleActionChain)
    with PTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> P' \<parallel> R'[x::=b]" by(rule Weak_Late_Step_Semantics.Comm2)
    moreover from PRel have "(P' \<parallel> R'[x::=b], Q' \<parallel> R'[x::=b]) \<in> Rel'" by(rule Par)
    ultimately show ?case by blast
  next
    case(cClose1 Q' R' a x y)
    have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and RTrans: "R \<longmapsto>a<\<nu>y> \<prec> R'" by fact+
    have "x \<sharp> (P, R)" and "y \<sharp> (P, R)" by fact+
    hence xFreshP: "x \<sharp> P" and yFreshR: "y \<sharp> R" and yFreshP: "y \<sharp> P" by(simp add: fresh_prod)+

    from PSimQ QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>ly in P''\<rightarrow>a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q'[x::=y]) \<in> Rel"
      by(blast dest: simE)
    from RTrans have "R \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> R'"
      by(auto simp add: weakTransition_def dest: Weak_Late_Step_Semantics.singleActionChain)
    with PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> <\<nu>y>(P' \<parallel> R')" using yFreshP yFreshR
      by(rule Weak_Late_Step_Semantics.Close1)
    moreover from P'RelQ' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q'[x::=y] \<parallel> R')) \<in> Rel'"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  next
    case(cClose2 Q' R' a x y)
    have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" and RTrans: "R \<longmapsto>a<x> \<prec> R'" by fact+
    have "x \<sharp> (P, R)" and "y \<sharp> (P, R)" by fact+
    hence xFreshR: "x \<sharp> R" and yFreshP: "y \<sharp> P" and yFreshR: "y \<sharp> R" by(simp add: fresh_prod)+

    from PSimQ QTrans yFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)

    from RTrans have "R \<Longrightarrow>\<^sub>ly in R'\<rightarrow>a<x> \<prec> R'[x::=y]"
      by(rule Weak_Late_Step_Semantics.singleActionChain)
    with PTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> <\<nu>y>(P' \<parallel> R'[x::=y])" using yFreshP yFreshR
      by(rule Weak_Late_Step_Semantics.Close2)
    moreover from P'RelQ' have "(<\<nu>y>(P' \<parallel> R'[x::=y]), <\<nu>y>(Q' \<parallel> R'[x::=y])) \<in> Rel'"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  qed
qed

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     ResRel: "\<And>(P::pi) (Q::pi) (x::name). (P, Q) \<in> Rel \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> Rel'"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel: "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "<\<nu>x>P \<leadsto><Rel'> <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[of _ "(P, Q, x)"])
    case(Bound Q' a y)
    have Trans: "<\<nu>x>Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
    have "y \<sharp> (P, Q, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" and "y \<sharp> Q" by(simp add: fresh_prod)+
    from Trans \<open>y \<noteq> x\<close> \<open>y \<sharp> Q\<close> show ?case
    proof(induct rule: resCasesB)
      case(cOpen a Q')
      have QTrans: "Q \<longmapsto>a[x] \<prec> Q'" and aineqx: "a \<noteq> x" by fact+

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

      have "<\<nu>x>P \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
      proof -
        from PTrans aineqx have "<\<nu>x>P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Open)
        moreover from PTrans yFreshP have "y \<sharp> P'" by(force intro: Weak_Late_Step_Semantics.freshTransition)
        ultimately show ?thesis by(simp add: alphaBoundResidual name_swap)
      qed
      moreover from EqvtRel P'RelQ' RelRel' have "([(y, x)] \<bullet> P', [(y, x)] \<bullet> Q') \<in> Rel'"
        by(blast intro: eqvtRelI)
      ultimately show ?case by blast
    next
      case(cRes Q')
      have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
      from \<open>x \<sharp> BoundOutputS a\<close> have "x \<noteq> a" by simp

      from PSimQ yFreshP QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans \<open>x \<noteq> a\<close> yineqx yFreshP have ResTrans: "<\<nu>x>P \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> (<\<nu>x>P')"
        by(blast intro: Weak_Late_Step_Semantics.ResB)
      moreover from P'RelQ' have "((<\<nu>x>P'), (<\<nu>x>Q')) \<in> Rel'"
        by(rule ResRel)
      ultimately show ?case by blast
    qed
  next
    case(Input Q' a y)
    have "y \<sharp> (P, Q, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" and "y \<sharp> Q" by(simp add: fresh_prod)+
    have "<\<nu>x>Q \<longmapsto>a<y> \<prec> Q'" by fact
    thus ?case using yineqx \<open>y \<sharp> Q\<close>
    proof(induct rule: resCasesB)
      case(cOpen a Q')
      thus ?case by simp
    next
      case(cRes Q')
      have QTrans: "Q \<longmapsto>a<y> \<prec> Q'" by fact
      from \<open>x \<sharp> InputS a\<close> have "x \<noteq> a" by simp

      from PSimQ QTrans yFreshP obtain P''
        where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P' \<and> (P', Q'[y::=u]) \<in> Rel"
        by(blast dest: simE)
      have "\<forall>u. \<exists>P'. <\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> P' \<and> (P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
      proof(rule allI)
        fix u
        show "\<exists>P'. <\<nu>x>P \<Longrightarrow>\<^sub>lu in <\<nu>x>P''\<rightarrow>a<y> \<prec> P' \<and> (P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
        proof(cases "x=u")
          assume xequ: "x=u"

          have "\<exists>c::name. c \<sharp> (P, P'', Q', x, y, a)" by(blast intro: name_exists_fresh)
          then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP'': "c \<sharp> P''" and cFreshQ': "c \<sharp> Q'"
                                and cineqx: "c \<noteq> x" and cineqy: "c \<noteq> y" and cineqa: "c \<noteq> a"
            by(force simp add: fresh_prod)

          from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lc in P''\<rightarrow>a<y> \<prec> P'"
                              and P'RelQ': "(P', Q'[y::=c]) \<in> Rel"
            by blast
          have "<\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>c>([(x, c)] \<bullet> P')"
          proof -
            from PTrans yineqx \<open>x \<noteq> a\<close> cineqx have "<\<nu>x>P \<Longrightarrow>\<^sub>lc in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>x>P'"
              by(blast intro: Weak_Late_Step_Semantics.ResB)
            hence "([(x, c)] \<bullet> <\<nu>x>P) \<Longrightarrow>\<^sub>l([(x, c)] \<bullet> c) in ([(x, c)] \<bullet> <\<nu>x>P'')\<rightarrow>([(x, c)] \<bullet> a)<([(x, c)] \<bullet> y)> \<prec> [(x, c)] \<bullet> <\<nu>x>P'"
              by(rule Weak_Late_Step_Semantics.eqvtI)
            moreover from cFreshP have "<\<nu>c>([(x, c)] \<bullet> P) = <\<nu>x>P" by(simp add: alphaRes)
            moreover from cFreshP'' have "<\<nu>c>([(x, c)] \<bullet> P'') = <\<nu>x>P''" by(simp add: alphaRes)
            ultimately show ?thesis using \<open>x \<noteq> a\<close> cineqa yineqx cineqy cineqx xequ by(simp add: name_calc)
          qed
          moreover have "(<\<nu>c>([(x, c)] \<bullet> P'), (<\<nu>x>Q')[y::=u]) \<in> Rel'"
          proof -
            from P'RelQ' have "(<\<nu>x>P', <\<nu>x>(Q'[y::=c])) \<in> Rel'" by(rule ResRel)
            with EqvtRel' have "([(x, c)] \<bullet> <\<nu>x>P', [(x, c)] \<bullet> <\<nu>x>(Q'[y::=c])) \<in> Rel'"  by(rule eqvtRelI)
            with cineqy yineqx cineqx have "(<\<nu>c>([(x, c)] \<bullet> P'), (<\<nu>c>([(x, c)] \<bullet> Q'))[y::=x]) \<in> Rel'"
              by(simp add: name_calc eqvt_subs)
            with cFreshQ' xequ show ?thesis by(simp add: alphaRes)
          qed
          ultimately show ?thesis by blast
        next
          assume xinequ: "x \<noteq> u"
          from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P'"
                             and P'RelQ': "(P', Q'[y::=u]) \<in> Rel" by blast

          from PTrans \<open>x \<noteq> a\<close> yineqx xinequ have "<\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>x>P'"
            by(blast intro: Weak_Late_Step_Semantics.ResB)
          moreover from P'RelQ' xinequ yineqx have "(<\<nu>x>P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
            by(force intro: ResRel)
          ultimately show ?thesis by blast
        qed
      qed
      thus ?case by blast
    qed
  next
    case(Free Q' \<alpha>)
    have "<\<nu>x>Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: resCasesF)
      case(cRes Q')
      have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
                             and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      have "<\<nu>x>P \<Longrightarrow>\<^sub>l\<alpha> \<prec> <\<nu>x>P'"
      proof -
        have xFreshAlpha: "x \<sharp> \<alpha>" by fact
        with PTrans show ?thesis by(rule Weak_Late_Step_Semantics.ResF)
      qed
      moreover from P'RelQ' have "(<\<nu>x>P', <\<nu>x>Q') \<in> Rel'" by(rule ResRel)
      ultimately show ?case by blast
    qed
  qed
qed

  shows "!P \<leadsto><bangRel Rel'> !Q"
proof -
  from eqvtRel' have EqvtBangRel': "eqvt(bangRel Rel')" by(rule eqvtBangRel)
  from RelRel' have BRelRel': "\<And>P Q. (P, Q) \<in> bangRel Rel \<Longrightarrow> (P, Q) \<in> bangRel Rel'"
    by(auto intro: bangRelSubset)

  have "\<And>Rs P. \<lbrakk>!Q \<longmapsto> Rs; (P, !Q) \<in> bangRel Rel\<rbrakk> \<Longrightarrow> weakStepSimAct P Rs P (bangRel Rel')"
  proof -
    fix Rs P
    assume "!Q \<longmapsto> Rs" and "(P, !Q) \<in> bangRel Rel"
    thus "weakStepSimAct P Rs P (bangRel Rel')"
    proof(nominal_induct avoiding: P rule: bangInduct)
      case(cPar1B aa x Q' P)
      have QTrans: "Q \<longmapsto>aa\<guillemotleft>x\<guillemotright> \<prec> Q'" and xFreshQ: "x \<sharp> Q" by fact+
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        from PRelQ have PSimQ: "P \<leadsto><Rel'> Q" by(rule Sim)
        from EqvtBangRel' show ?case
        proof(induct rule: simActBoundCases)
          case(Input a)
          have "aa = InputS a" by fact
          with PSimQ QTrans xFreshP obtain P''
            where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
            by(blast dest: simE)
          have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and> (P', (Q' \<parallel> !Q)[x::=u]) \<in> bangRel Rel'"
          proof(rule allI)
            fix u
            from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                                and P'RelQ': "(P', Q'[x::=u]) \<in> Rel'"
              by blast
            from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x>\<prec> P' \<parallel> R"
              by(rule Weak_Late_Step_Semantics.Par1B)
            moreover have "(P' \<parallel> R, (Q' \<parallel> !Q)[x::=u]) \<in> bangRel Rel'"
            proof -
              from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q'[x::=u] \<parallel> !Q) \<in> bangRel Rel'"
                by(blast intro: BRelRel' Rel.BRPar)
              with xFreshQ show ?thesis by(force simp add: forget)
            qed
            ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and>
                                  (P', (Q' \<parallel> !Q)[x::=u]) \<in> bangRel Rel'"
              by blast
          qed
          thus ?case by blast
        next
          case(BoundOutput a)
          have "aa = BoundOutputS a" by fact
          with PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
            by(force dest: simE)
          from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>la<\<nu>x>\<prec> P' \<parallel> R"
            by(rule Weak_Late_Step_Semantics.Par1B)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel'"
            by(blast intro: Rel.BRPar BRelRel')
          ultimately show ?case by blast
        qed
      qed
    next
      case(cPar1F \<alpha> Q' P)
      have QTrans: "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(induct rule: simActFreeCases)
          case Free
          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Late_Step_Semantics.Par1F)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel'"
            by(blast intro: BRelRel' Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cPar2B aa x Q' P)
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (aa\<guillemotleft>x\<guillemotright> \<prec> Q') P (bangRel Rel')" by fact
      have xFreshQ: "x \<sharp> Q" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        from RBangRelQ have IH: "weakStepSimAct R (aa\<guillemotleft>x\<guillemotright> \<prec> Q') R (bangRel Rel')" by(rule IH)
        from EqvtBangRel' show ?case
        proof(induct rule: simActBoundCases)
          case(Input a)
          have "aa = InputS a" by fact
          with xFreshR IH obtain  R'' where L1: "\<forall>u. \<exists>R'. R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R' \<and>
                                                 (R', Q'[x::=u]) \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)
          have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and> (P', (Q \<parallel> Q')[x::=u]) \<in> bangRel Rel'"
          proof(rule allI)
            fix u
            from L1 obtain R' where RTrans: "R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R'"
                                and R'BangRelT': "(R', Q'[x::=u]) \<in> bangRel Rel'"
              by blast

            from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P \<parallel> R'"
              by(rule Weak_Late_Step_Semantics.Par2B)
            moreover have "(P \<parallel> R', (Q \<parallel> Q')[x::=u]) \<in> bangRel Rel'"
            proof -
              from PRelQ R'BangRelT' have "(P \<parallel> R', Q \<parallel> Q'[x::=u]) \<in> bangRel Rel'"
                by(blast intro: RelRel' Rel.BRPar)
              with xFreshQ show ?thesis by(simp add: forget)
            qed
            ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and> (P', (Q \<parallel> Q')[x::=u]) \<in> bangRel Rel'"
              by blast
          qed
          thus ?case by blast
        next
          case(BoundOutput a)
          have "aa = BoundOutputS a" by fact
          with IH xFreshR obtain R' where RTrans: "R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> R'"
                                      and R'BangRelT': "(R', Q') \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)

          from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P \<parallel> R'"
            by(auto intro: Weak_Late_Step_Semantics.Par2B)
          moreover from PRelQ R'BangRelT' have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel'"
            by(blast intro: RelRel' Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cPar2F \<alpha> Q')
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (\<alpha> \<prec> Q') P (bangRel Rel')" by fact+
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(induct rule: simActFreeCases)
          case Free
          from RBangRelQ have "weakStepSimAct R (\<alpha> \<prec> Q') R (bangRel Rel')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<alpha> \<prec> R'" and R'BangRelQ': "(R', Q') \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)

          from RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Late_Step_Semantics.Par2F)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel'"
            by(blast intro: RelRel' Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cComm1 a x Q' b Q'' P)
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (a[b] \<prec> Q'') P (bangRel Rel')" by fact+
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" by simp
        show ?case
        proof(induct rule: simActFreeCases)
          case Free
          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>lb in P''\<rightarrow>a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q'[x::=b]) \<in> Rel'"
            by(blast dest: simE)

          from RBangRelQ have "weakStepSimAct R (a[b] \<prec> Q'') R (bangRel Rel')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sub>la[b] \<prec> R'"
                           and R'RelT': "(R', Q'') \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)
          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Late_Step_Semantics.Comm1)
          moreover from P'RelQ' R'RelT' have "(P' \<parallel> R', Q'[x::=b] \<parallel> Q'') \<in> bangRel Rel'"
            by(blast intro: RelRel' Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cComm2 a b Q' x Q'' P)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (a<x> \<prec> Q'') P (bangRel Rel')"
        by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshR: "x \<sharp> R" by simp
        show ?case
        proof(induct rule: simActFreeCases)
          case Free

          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la[b] \<prec> P'"
                                  and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

          from RBangRelQ have "weakStepSimAct R (a<x> \<prec> Q'') R (bangRel Rel')"
            by(rule IH)
          with xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>lb in R''\<rightarrow>a<x> \<prec> R'"
                                       and R'BangRelQ'': "(R', Q''[x::=b]) \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Late_Step_Semantics.Comm2)
          moreover from P'RelQ' R'BangRelQ'' have "(P' \<parallel> R', Q' \<parallel> Q''[x::=b]) \<in> bangRel Rel'"
            by(rule Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cClose1 a x Q' y Q'' P)
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (a<\<nu>y> \<prec> Q'') P (bangRel Rel')"
        by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" and "y \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" and "y \<sharp> P \<parallel> R" by fact+
        hence xFreshP: "x \<sharp> P" and yFreshR: "y \<sharp> R" and yFreshP: "y \<sharp> P" by simp+
        show ?case
        proof(induct rule: simActFreeCases)
          case Free
          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>ly in P''\<rightarrow>a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q'[x::=y]) \<in> Rel'"
            by(blast dest: simE)

          from RBangRelQ have "weakStepSimAct R (a<\<nu>y> \<prec> Q'') R (bangRel Rel')" by(rule IH)
          with yFreshR obtain R' where RTrans: "R \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> R'"
                                   and R'BangRelQ'': "(R', Q'') \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)
          from PTrans RTrans yFreshP yFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
            by(rule Weak_Late_Step_Semantics.Close1)
          moreover from P'RelQ' R'BangRelQ'' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q'[x::=y] \<parallel> Q'')) \<in> bangRel Rel'"
            by(force intro: Rel.BRPar Rel.BRRes)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cClose2 a y Q' x Q'')
      have QTrans: "Q \<longmapsto> a<\<nu>y> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P (a<x> \<prec> Q'') P (bangRel Rel')"
        by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" and "y \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" and "y \<sharp> P \<parallel> R" by fact+
        hence xFreshR: "x \<sharp> R" and yFreshR: "y \<sharp> R" and yFreshP: "y \<sharp> P" by simp+
        show ?case
        proof(induct rule: simActFreeCases)
          case Free
          from PRelQ have "P \<leadsto><Rel'> Q" by(rule Sim)
          with QTrans yFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>y> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel'"
            by(blast dest: simE)

          from RBangRelQ have "weakStepSimAct R (a<x> \<prec> Q'') R (bangRel Rel')"
            by(rule IH)
          with xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>ly in R''\<rightarrow>a<x> \<prec> R'"
                                       and R'BangRelT': "(R', Q''[x::=y]) \<in> bangRel Rel'"
            by(simp add: weakStepSimAct_def, blast)

          from PTrans RTrans yFreshP yFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l\<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
            by(rule Weak_Late_Step_Semantics.Close2)
          moreover from P'RelQ' R'BangRelT' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q' \<parallel> Q''[x::=y])) \<in> bangRel Rel'"
            by(force intro: Rel.BRPar Rel.BRRes)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cBang Rs)
      have IH: "\<And>P. (P, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> weakStepSimAct P Rs P (bangRel Rel')"
        by fact
      have "(P, !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        have PRelQ: "(P, Q) \<in> Rel" by fact
        hence "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
        with PRelQ have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
        hence "weakStepSimAct (P \<parallel> !P) Rs (P \<parallel> !P) (bangRel Rel')" by(rule IH)
        thus ?case
        proof(simp (no_asm) add: weakStepSimAct_def, auto)
          fix Q' a x
          assume "weakStepSimAct (P \<parallel> !P) (a<\<nu>x> \<prec> Q') (P \<parallel> !P) (bangRel Rel')" and "x \<sharp> P"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> (bangRel Rel')"
            by(simp add: weakStepSimAct_def, blast)
          from PTrans have "!P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
            by(rule Weak_Late_Step_Semantics.Bang)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> bangRel Rel'" by blast
        next
          fix Q' a x
          assume "weakStepSimAct (P \<parallel> !P) (a<x> \<prec> Q') (P \<parallel> !P) (bangRel Rel')" and "x \<sharp> P"
          then obtain P'' where L1: "\<forall>u. \<exists>P'. P \<parallel> !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> (bangRel Rel')"
            by(simp add: weakStepSimAct_def, blast)
          have "\<forall>u. \<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> (bangRel Rel')"
          proof(rule allI)
            fix u
            from L1 obtain P' where PTrans: "P \<parallel> !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                                and P'RelQ': "(P', Q'[x::=u]) \<in> (bangRel Rel')"
              by blast
            from PTrans have "!P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Bang)
            with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> (bangRel Rel')" by blast
          qed
          thus "\<exists>P''. \<forall>u. \<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> (bangRel Rel')" by blast
        next
          fix Q' \<alpha>
          assume "weakStepSimAct (P \<parallel> !P) (\<alpha> \<prec> Q') (P \<parallel> !P) (bangRel Rel')"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> (bangRel Rel')"
            by(simp add: weakStepSimAct_def, blast)
          from PTrans have "!P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
            by(rule Weak_Late_Step_Semantics.Bang)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> (bangRel Rel')" by blast
        qed
      qed
    qed
  qed
  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
  ultimately show ?thesis by(simp add: weakStepSim_def)
qed

end