section \<open> Stateful-Failure Programs \<close>

theory utp_sfrd_prog
  imports
    "UTP1.utp_full"
    utp_sfrd_extchoice
begin

subsection \<open> Conditionals \<close>

lemma NCSP_cond_srea [closure]:
  assumes "P is NCSP" "Q is NCSP"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q is NCSP"
  by (rule NCSP_NSRD_intro, simp_all add: closure rdes assms unrest)

subsection \<open> Guarded commands \<close>

lemma GuardedCommR_NCSP_closed [closure]:
  assumes "P is NCSP"
  shows "g \<rightarrow>\<^sub>R P is NCSP"
  by (simp add: gcmd_def closure assms)

subsection \<open> Alternation \<close>

lemma AlternateR_NCSP_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P(i) is NCSP" "Q is NCSP"
  shows "(if\<^sub>R i\<in>A \<bullet> g(i) \<rightarrow> P(i) else Q fi) is NCSP"
proof (cases "A = {}")
  case True
  then show ?thesis
    by (simp add: assms)
next
  case False
  then show ?thesis
    by (simp add: AlternateR_def closure assms)
qed

lemma AlternateR_list_NCSP_closed [closure]:
  assumes "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is NCSP" "Q is NCSP"
  shows "(AlternateR_list A Q) is NCSP"
  apply (simp add: AlternateR_list_def)
  apply (rule AlternateR_NCSP_closed)
  apply (auto simp add: assms)
  apply (metis assms(1) eq_snd_iff nth_mem)
  done

subsection \<open> Specification Statement \<close>

definition SpecC :: "('a \<Longrightarrow> 's) \<Rightarrow> 's upred \<Rightarrow> 's upred \<Rightarrow> ('s, 'e) action" ("_:[_,_]\<^sub>C" [999,0,0] 999) where
[rdes_def]: "SpecC frm pre post = \<^bold>R\<^sub>s([pre]\<^sub>S\<^sub>< \<turnstile> false \<diamondop> [frm:[post\<^sup>>]]\<^sub>S)"

lemma SpecC_is_NCSP [closure]: "frm:[pre,post]\<^sub>C is NCSP"
  apply (simp add: SpecC_def)
  apply (rule NCSP_rdes_intro)
      apply (simp_all add: closure unrest)
   apply (rel_auto)+
  done

lemma SpecC_skip: "{}\<^sub>v:[true,true]\<^sub>C = Skip"
  by (rdes_eq)

lemma SpecC_false_pre: "a:[false,q]\<^sub>C = Chaos"
  by (rdes_eq)

lemma SpecC_false_post: "a:[true,false]\<^sub>C = Miracle"
  by (rdes_eq)

lemma SpecC_refine_seq:
  "vwb_lens a \<Longrightarrow> a:[p,q]\<^sub>C \<sqsubseteq> a:[p,r]\<^sub>C ;; a:[r,q]\<^sub>C"
  by ((rdes_refine_split; rel_simp), metis vwb_lens.put_eq)

subsection \<open> Assumptions \<close>

definition AssumeCircus ("[_]\<^sub>C") where
"[b]\<^sub>C = b \<rightarrow>\<^sub>R Skip"

lemma AssumeCircus_rdes_def [rdes_def]: "[b]\<^sub>C = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> false \<diamondop> [b]\<^sub>c)"
  unfolding AssumeCircus_def by rdes_eq

lemma AssumeCircus_NCSP [closure]: "[b]\<^sub>C is NCSP"
  by (simp add: AssumeCircus_def GuardedCommR_NCSP_closed NCSP_Skip)

lemma AssumeCircus_AssumeR: "Skip ;; [b]\<^sup>\<top>\<^sub>R = [b]\<^sub>C" "[b]\<^sup>\<top>\<^sub>R ;; Skip = [b]\<^sub>C"
  by (rdes_eq)+

lemma AssumeR_comp_AssumeCircus: "P is NCSP \<Longrightarrow> P ;; [b]\<^sup>\<top>\<^sub>R = P ;; [b]\<^sub>C"
  by (metis (no_types, opaque_lifting) AssumeCircus_AssumeR(1) RA1 Skip_right_unit)

lemma gcmd_AssumeCircus:
  "P is NCSP \<Longrightarrow> b \<rightarrow>\<^sub>R P = [b]\<^sub>C ;; P"
  by (simp add: AssumeCircus_def NCSP_implies_NSRD Skip_left_unit gcmd_seq_distr)

lemma rdes_assume_pre_refine:
  assumes "P is NCSP"
  shows "P \<sqsubseteq> [b]\<^sub>C ;; P"
  by (rdes_refine cls: assms)

subsection \<open> While Loops \<close>

lemma NSRD_coerce_NCSP:
  "P is NSRD \<Longrightarrow> Skip ;; P ;; Skip is NCSP"
  by (metis (no_types, opaque_lifting) CSP3_Skip CSP3_def CSP4_def Healthy_def NCSP_Skip NCSP_implies_CSP NCSP_intro NSRD_is_SRD RA1 SRD_seqr_closure)

definition WhileC :: "'s upred \<Rightarrow> ('s, 'e) action \<Rightarrow> ('s, 'e) action" ("while\<^sub>C _ do _ od") where
"while\<^sub>C b do P od = Skip ;; while\<^sub>R b do P od ;; Skip"

lemma WhileC_NCSP_closed [closure]:
  assumes "P is NCSP" "P is Productive"
  shows "while\<^sub>C b do P od is NCSP"
  by (simp add: WhileC_def NSRD_coerce_NCSP assms closure)

theorem WhileC_iter_form:
  assumes "P is NCSP" "P is Productive"
  shows "while\<^sub>C b do P od = ([b]\<^sub>C ;; P)\<^sup>\<star>\<^sup>C ;; [\<not> b]\<^sub>C"
  by (simp add: WhileC_def WhileR_iter_form assms closure)
     (metis (no_types, lifting) StarC_def AssumeCircus_AssumeR(2) AssumeCircus_NCSP RA1 assms(1) csp_theory.Healthy_Sequence csp_theory.Star_Healthy csp_theory.Unit_Left sfrd_star_as_rdes_star)

theorem WhileC_rdes_def [rdes_def]:
  assumes "P is CRC" "Q is CRR" "R is CRF" "$st\<acute> \<sharp> Q" "R is R4"
  shows "while\<^sub>C b do \<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) od =
         \<^bold>R\<^sub>s (([b]\<^sub>c ;; R)\<^sup>\<star>\<^sup>c wp\<^sub>r ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> (([b]\<^sub>c ;; R)\<^sup>\<star>\<^sup>c ;; [b]\<^sub>c ;; Q) \<diamondop> (([b]\<^sub>c ;; R)\<^sup>\<star>\<^sup>c ;; [\<not> b]\<^sub>c))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = ([b]\<^sub>C ;; \<^bold>R\<^sub>s (P \<turnstile> Q \<diamondop> R))\<^sup>\<star>\<^sup>C ;; [\<not> b]\<^sub>C"
    by (simp add: WhileC_iter_form assms closure unrest Productive_rdes_RR_intro)
  also have "... = ?rhs"
    by (simp add: rdes_def assms closure unrest rpred wp del: rea_star_wp)
  finally show ?thesis .
qed

lemma WhileC_false:
  "P is NCSP \<Longrightarrow> WhileC false P = Skip"
  by (simp add: NCSP_implies_NSRD Skip_srdes_left_unit WhileC_def WhileR_false)

lemma WhileC_unfold:
  assumes "P is NCSP" "P is Productive"
  shows "WhileC b P = (P ;; WhileC b P) \<triangleleft> b \<triangleright>\<^sub>R Skip"
proof -
  have "WhileC b P = (Skip \<or> [b]\<^sub>C ;; P ;; ([b]\<^sub>C ;; P)\<^sup>\<star>\<^sup>C) ;; [\<not> b]\<^sub>C"
    by (simp add: WhileC_iter_form assms closure)
       (metis (no_types, lifting) AssumeCircus_NCSP RA1 StarC_unfold assms(1) csp_theory.Healthy_Sequence disj_upred_def)
  also have "... = ([\<not> b]\<^sub>C \<or> [b]\<^sub>C ;; P ;; ([b]\<^sub>C ;; P)\<^sup>\<star>\<^sup>C ;; [\<not> b]\<^sub>C)"
    by (metis (no_types, lifting) AssumeCircus_AssumeR(1) RA1 csp_theory.Unit_self seqr_or_distl)
  also have "... = (P ;; WhileC b P) \<triangleleft> b \<triangleright>\<^sub>R Skip"
    by (metis (no_types, lifting) AssumeCircus_AssumeR(2) NCSP_implies_NSRD RA1 WhileC_NCSP_closed WhileC_iter_form assms(1) assms(2) cond_srea_AssumeR_form csp_theory.Healthy_Sequence csp_theory.Healthy_Unit csp_theory.Unit_Left uinf_or utp_pred_laws.sup_commute)
  finally show ?thesis .
qed

subsection \<open> Iteration Construction \<close>

definition IterateC :: "'a set \<Rightarrow> ('a \<Rightarrow> 's upred) \<Rightarrow> ('a \<Rightarrow> ('s, 'e) action) \<Rightarrow> ('s, 'e) action"
where [upred_defs, ndes_simp]: "IterateC A g P = while\<^sub>C (\<Or> i\<in>A \<bullet> g(i)) do (if\<^sub>R i\<in>A \<bullet> g(i) \<rightarrow> P(i) fi) od"

lemma IterateC_IterateR_def: "IterateC A g P = Skip ;; IterateR A g P ;; Skip"
  by (simp add: IterateC_def IterateR_def WhileC_def)

definition IterateC_list :: "('s upred \<times> ('s, 'e) action) list \<Rightarrow> ('s, 'e) action" where
[upred_defs, ndes_simp]:
  "IterateC_list xs = IterateC {0..<length xs} (\<lambda> i. map fst xs ! i) (\<lambda> i. map snd xs ! i)"

syntax
  "_iter_C"    :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("do\<^sub>C _\<in>_ \<bullet> _ \<rightarrow> _ od")
  "_iter_gcommC" :: "gcomms \<Rightarrow> logic" ("do\<^sub>C/ _ /od")

translations
  "_iter_C x A g P" => "CONST IterateC A (\<lambda> x. g) (\<lambda> x. P)"
  "_iter_C x A g P" <= "CONST IterateC A (\<lambda> x. g) (\<lambda> x'. P)"
  "_iter_gcommC cs" \<rightharpoonup> "CONST IterateC_list cs"
  "_iter_gcommC (_gcomm_show cs)" \<leftharpoondown> "CONST IterateC_list cs"

lemma IterateC_NCSP_closed [closure]:
  assumes
    "\<And> i. i \<in> I \<Longrightarrow> P(i) is NCSP"
    "\<And> i. i \<in> I \<Longrightarrow> P(i) is Productive"
  shows "do\<^sub>C i\<in>I \<bullet> g(i) \<rightarrow> P(i) od is NCSP"
  by (simp add: IterateC_IterateR_def IterateR_NSRD_closed NCSP_implies_NSRD NSRD_coerce_NCSP assms(1) assms(2))

lemma IterateC_list_NCSP_closed [closure]:
  assumes
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is NCSP"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is Productive"
  shows "IterateC_list A is NCSP"
  apply (simp add: IterateC_list_def, rule IterateC_NCSP_closed)
   apply (metis assms atLeastLessThan_iff nth_map nth_mem prod.collapse)+
  done

lemma IterateC_list_alt_def:
  "IterateC_list xs = while\<^sub>C (\<Or> b \<in> set(map fst xs) \<bullet> b) do AlternateR_list xs Chaos od"
proof -
  have "(\<Or> i \<in> {0..<length(xs)} \<bullet> (map fst xs) ! i) = (\<Or> b \<in> set(map fst xs) \<bullet> b)"
    by (rel_auto, metis fst_conv in_set_conv_nth nth_map)
  thus ?thesis
    by (simp add: IterateC_list_def IterateC_def AlternateR_list_def)
qed

lemma IterateC_empty:
  "do\<^sub>C i\<in>{} \<bullet> g(i) \<rightarrow> P(i) od = Skip"
  by (simp add: IterateC_IterateR_def IterateR_empty closure Skip_srdes_left_unit)

lemma IterateC_singleton:
  assumes "P k is NCSP" "P k is Productive"
  shows "do\<^sub>C i\<in>{k} \<bullet> g(i) \<rightarrow> P(i) od = while\<^sub>C g(k) do P(k) od" (is "?lhs = ?rhs")
  by (simp add: IterateC_IterateR_def IterateR_singleton NCSP_implies_NSRD WhileC_def assms)

lemma IterateC_outer_refine_intro:
  assumes "I \<noteq> {}" "\<And> i. i \<in> I \<Longrightarrow> P i is NCSP" "\<And> i. i \<in> I \<Longrightarrow> P i is Productive"
    "\<And> i. i \<in> I \<Longrightarrow> S \<sqsubseteq> (b i \<rightarrow>\<^sub>R P i ;; S)" "S is NCSP"
    "S \<sqsubseteq> [\<not> (\<Sqinter> i \<in> I \<bullet> b i)]\<^sup>\<top>\<^sub>R"
  shows "S \<sqsubseteq> do\<^sub>C i\<in>I \<bullet> b(i) \<rightarrow> P(i) od"
proof -
  have "S \<sqsubseteq> do\<^sub>R i\<in>I \<bullet> b(i) \<rightarrow> P(i) od"
    by (simp add: IterateR_outer_refine_intro NCSP_implies_NSRD assms)
  thus ?thesis
    unfolding IterateC_IterateR_def
    by (metis (full_types) Skip_left_unit Skip_right_unit assms(5) urel_dioid.mult_isol urel_dioid.mult_isor)
qed

lemma IterateC_outer_refine_init_intro:
  assumes
    "\<And> i. i \<in> A \<Longrightarrow> P i is NCSP"
    "\<And> i. i \<in> A \<Longrightarrow> P i is Productive"
    "S is NCSP" "I is NCSP"
    "S \<sqsubseteq> I ;; [\<not> (\<Sqinter> i \<in> A \<bullet> b i)]\<^sup>\<top>\<^sub>R"
    "\<And> i. i \<in> A \<Longrightarrow> S \<sqsubseteq> S ;; b i \<rightarrow>\<^sub>R P i"
    "\<And> i. i \<in> A \<Longrightarrow> S \<sqsubseteq> I ;; b i \<rightarrow>\<^sub>R P i"
  shows "S \<sqsubseteq> I ;; do\<^sub>C i\<in>A \<bullet> b(i) \<rightarrow> P(i) od"
proof (cases "A = {}")
  case True
  with assms(5) show ?thesis
    by (simp add: IterateC_empty assms closure Skip_right_unit AssumeR_true NSRD_right_unit)
next
  case False
  have "S \<sqsubseteq> I ;; do\<^sub>R i\<in>A \<bullet> b(i) \<rightarrow> P(i) od"
    by (simp add: IterateR_outer_refine_init_intro NCSP_implies_NSRD assms False)
  thus ?thesis
    unfolding IterateC_IterateR_def
    by (metis (no_types, opaque_lifting) RA1 Skip_right_unit assms(3) assms(4) urel_dioid.mult_isor)
qed

lemma IterateC_list_outer_refine_intro:
  assumes
    "A \<noteq> []" "S is NCSP"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is NCSP"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is Productive"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> S \<sqsubseteq> (b \<rightarrow>\<^sub>R P ;; S)"
    "S \<sqsubseteq> [\<not> (\<Sqinter> (b, P) \<in> set A \<bullet> b)]\<^sup>\<top>\<^sub>R"
  shows "S \<sqsubseteq> IterateC_list A"
proof -
  have "(\<Sqinter> i \<in> {0..<length(A)} \<bullet> (map fst A) ! i) = (\<Sqinter> (b, P) \<in> set A \<bullet> b)"
    by (rel_auto, metis nth_mem prod.exhaust_sel, metis fst_conv in_set_conv_nth nth_map)
  thus ?thesis
    apply (simp add: IterateC_list_def)
    apply (rule IterateC_outer_refine_intro)
     apply (simp_all add: closure assms)
    apply (metis assms(3) nth_mem prod.collapse)
    apply (metis assms(4) nth_mem prod.collapse)
    done
qed

lemma IterateC_list_outer_refine_init_intro:
  assumes
    "S is NCSP" "I is NCSP"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is NCSP"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> P is Productive"
    "S \<sqsubseteq> I ;; [\<not> (\<Sqinter> (b, P) \<in> set A \<bullet> b)]\<^sup>\<top>\<^sub>R"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> S \<sqsubseteq> S ;; b \<rightarrow>\<^sub>R P"
    "\<And> b P. (b, P) \<in> set A \<Longrightarrow> S \<sqsubseteq> I ;; b \<rightarrow>\<^sub>R P"
  shows "S \<sqsubseteq> I ;; IterateC_list A"
proof -
  have "(\<Sqinter> i \<in> {0..<length(A)} \<bullet> (map fst A) ! i) = (\<Sqinter> (b, P) \<in> set A \<bullet> b)"
    by (rel_auto, metis nth_mem prod.exhaust_sel, metis fst_conv in_set_conv_nth nth_map)
  thus ?thesis
    apply (simp add: IterateC_list_def)
    apply (rule IterateC_outer_refine_init_intro)
     apply (simp_all add: closure assms)
    apply (metis assms(3) nth_mem prod.collapse)
    apply (metis assms(4) nth_mem prod.collapse)
    done
qed

subsection \<open> Assignment \<close>

definition AssignsCSP :: "'\<sigma> usubst \<Rightarrow> ('\<sigma>, '\<phi>) action" ("\<langle>_\<rangle>\<^sub>C") where
[upred_defs]: "AssignsCSP \<sigma> = \<^bold>R\<^sub>s(true \<turnstile> false \<diamondop> ($tr\<acute> =\<^sub>u $tr \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>S))"

abbreviation "AssignCSP x v \<equiv> \<^bold>R\<^sub>s([&\<^bold>v \<in>\<^sub>u \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>]\<^sub>S\<^sub>< \<turnstile> false \<diamondop> \<Phi>(true,[x \<mapsto>\<^sub>s v], \<guillemotleft>[]\<guillemotright>))"

syntax
  "_assigns_csp" :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  ("'(_') :=\<^sub>C '(_')")
  "_assigns_csp" :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr ":=\<^sub>C" 64)

translations
  "_assigns_csp xs vs" => "CONST AssignsCSP (_mk_usubst id\<^sub>s xs vs)"
  "_assigns_csp x v" <= "CONST AssignsCSP (CONST subst_upd id\<^sub>s x v)"
  "_assigns_csp x v" <= "_assigns_csp (_spvar x) v"
  "x,y :=\<^sub>C u,v" <= "CONST AssignsCSP (CONST subst_upd (CONST subst_upd (id\<^sub>s) (CONST pr_var x) u) (CONST pr_var y) v)"

lemma preR_AssignsCSP [rdes]: "pre\<^sub>R(\<langle>\<sigma>\<rangle>\<^sub>C) = true\<^sub>r"
  by (rel_auto)

lemma periR_AssignsCSP [rdes]: "peri\<^sub>R(\<langle>\<sigma>\<rangle>\<^sub>C) = false"
  by (rel_auto)

lemma postR_AssignsCSP [rdes]: "post\<^sub>R(\<langle>\<sigma>\<rangle>\<^sub>C) = \<Phi>(true,\<sigma>,\<guillemotleft>[]\<guillemotright>)"
  by (rel_auto)

lemma AssignsCSP_rdes_def [rdes_def] : "\<langle>\<sigma>\<rangle>\<^sub>C = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> false \<diamondop> \<Phi>(true,\<sigma>,\<guillemotleft>[]\<guillemotright>))"
  by (rel_auto)

lemma AssignsCSP_CSP [closure]: "\<langle>\<sigma>\<rangle>\<^sub>C is CSP"
  by (simp add: AssignsCSP_def RHS_tri_design_is_SRD unrest)

lemma AssignsCSP_CSP3 [closure]: "\<langle>\<sigma>\<rangle>\<^sub>C is CSP3"
  by (rule CSP3_intro, simp add: closure, rel_auto)

lemma AssignsCSP_CSP4 [closure]: "\<langle>\<sigma>\<rangle>\<^sub>C is CSP4"
  by (rule CSP4_intro, simp add: closure, rel_auto+)

lemma AssignsCSP_NCSP [closure]: "\<langle>\<sigma>\<rangle>\<^sub>C is NCSP"
  by (simp add: AssignsCSP_CSP AssignsCSP_CSP3 AssignsCSP_CSP4 NCSP_intro)

lemma AssignsCSP_ICSP [closure]: "\<langle>\<sigma>\<rangle>\<^sub>C is ICSP"
  apply (rule ICSP_intro, simp add: closure, simp add: rdes_def)
  apply (rule ISRD1_rdes_intro)
  apply (simp_all add: closure)
  apply (rel_auto)
done

lemma unproductive_AssignsCSP: "\<not> (\<langle>\<sigma>\<rangle>\<^sub>C is Productive)"
  unfolding rdes_def by (rule unproductive_form, simp_all add: closure, rel_auto+)

lemma AssignsCSP_as_AssignsR: "\<langle>\<sigma>\<rangle>\<^sub>R ;; Skip = \<langle>\<sigma>\<rangle>\<^sub>C"
  by (rdes_eq)

lemma AssignC_init_refine_intro:
  assumes
    "vwb_lens x" "$st:x \<sharp> P\<^sub>2" "$st:x \<sharp> P\<^sub>3"
    "P\<^sub>2 is RR" "P\<^sub>3 is RR" "Q is NCSP"
    "\<^bold>R\<^sub>s([&x =\<^sub>u \<guillemotleft>k\<guillemotright>]\<^sub>S\<^sub>< \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<sqsubseteq> Q"
  shows "\<^bold>R\<^sub>s(true\<^sub>r \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<sqsubseteq> (x :=\<^sub>C \<guillemotleft>k\<guillemotright>) ;; Q"
  by (simp add: AssignsCSP_as_AssignsR[THEN sym] assms seqr_assoc Skip_left_unit AssignR_init_refine_intro closure)

lemma AssignsCSP_refines_sinv:
  assumes "`\<sigma> \<dagger> b`"
  shows "sinv\<^sub>R(b) \<sqsubseteq> \<langle>\<sigma>\<rangle>\<^sub>C"
  apply (rdes_refine_split)
  apply (simp_all)
   apply (metis rea_st_cond_true st_cond_conj utp_pred_laws.inf.absorb_iff2 utp_pred_laws.inf_top_left)
  using assms apply (rel_auto)
  done

subsection \<open> Assignment with update \<close>

text \<open> There are different collections that we would like to assign to, but they all have different
  types and perhaps more importantly different conditions on the update being well defined. For example,
  for a list well-definedness equates to the index being less than the length etc. Thus we here set
  up a polymorphic constant for CSP assignment updates that can be specialised to different types. \<close>

definition AssignCSP_update ::
  "('f \<Rightarrow> 'k set) \<Rightarrow> ('f \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 'f) \<Rightarrow> ('f \<Longrightarrow> '\<sigma>) \<Rightarrow>
   ('k, '\<sigma>) uexpr \<Rightarrow> ('v, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>, '\<phi>) action" where
[upred_defs,rdes_def]: "AssignCSP_update domf updatef x k v =
  \<^bold>R\<^sub>s([k \<in>\<^sub>u uop domf (&x)]\<^sub>S\<^sub>< \<turnstile> false \<diamondop> \<Phi>(true,[x \<mapsto>\<^sub>s trop updatef (&x) k v], \<guillemotleft>[]\<guillemotright>))"

text \<open> All different assignment updates have the same syntax; the type resolves which implementation
  to use. \<close>

syntax
  "_csp_assign_upd" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_[_] :=\<^sub>C _" [61,0,62] 62)

translations
  "_csp_assign_upd x k v" == "CONST AssignCSP_update (CONST Relation_Toolkit.dom) (CONST uupd) x k v"

lemma AssignCSP_update_CSP [closure]:
  "AssignCSP_update domf updatef x k v is CSP"
  by (simp add: AssignCSP_update_def RHS_tri_design_is_SRD unrest)

lemma preR_AssignCSP_update [rdes]:
  "pre\<^sub>R(AssignCSP_update domf updatef x k v) = [k \<in>\<^sub>u uop domf (&x)]\<^sub>S\<^sub><"
  by (rel_auto)

lemma periR_AssignCSP_update [rdes]:
  "peri\<^sub>R(AssignCSP_update domf updatef x k v) = [k \<notin>\<^sub>u uop domf (&x)]\<^sub>S\<^sub><"
  by (rel_simp)

lemma post_AssignCSP_update [rdes]:
  "post\<^sub>R(AssignCSP_update domf updatef x k v) =
    (\<Phi>(true,[x \<mapsto>\<^sub>s trop updatef (&x) k v],\<guillemotleft>[]\<guillemotright>) \<triangleleft> (k \<in>\<^sub>u uop domf (&x)) \<triangleright>\<^sub>R R1(true))"
  by (rel_auto)

lemma AssignCSP_update_NCSP [closure]:
  "(AssignCSP_update domf updatef x k v) is NCSP"
proof (rule NCSP_intro)
  show "(AssignCSP_update domf updatef x k v) is CSP"
    by (simp add: closure)
  show "(AssignCSP_update domf updatef x k v) is CSP3"
    by (rule CSP3_SRD_intro, simp_all add: csp_do_def closure rdes unrest)
  show "(AssignCSP_update domf updatef x k v) is CSP4"
    by (rule CSP4_tri_intro, simp_all add: csp_do_def closure rdes unrest, rel_auto)
qed

subsection \<open> State abstraction \<close>

lemma ref_unrest_abs_st [unrest]:
  "$ref \<sharp> P \<Longrightarrow> $ref \<sharp> \<langle>P\<rangle>\<^sub>S"
  "$ref\<acute> \<sharp> P \<Longrightarrow> $ref\<acute> \<sharp> \<langle>P\<rangle>\<^sub>S"
  by (rel_simp)+

lemma NCSP_state_srea [closure]: "P is NCSP \<Longrightarrow> state 'a \<bullet> P is NCSP"
  apply (rule NCSP_NSRD_intro)
  apply (simp_all add: closure rdes)
  apply (simp_all add: state_srea_def unrest closure)
done

subsection \<open> Guards \<close>

definition GuardCSP ::
  "'\<sigma> cond \<Rightarrow>
   ('\<sigma>, '\<phi>) action \<Rightarrow>
   ('\<sigma>, '\<phi>) action"  where
[upred_defs]: "GuardCSP g A = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R(A)) \<turnstile> ((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> cmt\<^sub>R(A)) \<or> (\<lceil>\<not> g\<rceil>\<^sub>S\<^sub><) \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"

syntax
  "_GuardCSP" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr "&\<^sub>C" 60)

translations
  "_GuardCSP b P" == "CONST GuardCSP b P"

lemma Guard_tri_design:
  "g &\<^sub>C P = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P) \<turnstile> (peri\<^sub>R(P) \<triangleleft> \<lceil>g\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)) \<diamondop> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> post\<^sub>R(P)))"
proof -
  have "(\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> cmt\<^sub>R P \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>) = (peri\<^sub>R(P) \<triangleleft> \<lceil>g\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)) \<diamondop> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> post\<^sub>R(P))"
    by (rel_auto)
  thus ?thesis by (simp add: GuardCSP_def)
qed

lemma csp_do_cond_conj:
  assumes "P is CRR"
  shows "(\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> P) = \<Phi>(b, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; P"
proof -
  have "(\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> CRR(P)) = \<Phi>(b, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; CRR(P)"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma Guard_rdes_def [rdes_def]:
  assumes "P is RR" "Q is CRR" "R is CRR"
  shows "g &\<^sub>C \<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) = \<^bold>R\<^sub>s (([g]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> ((\<Phi>(g, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; Q) \<or> \<E>(\<not>g,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u)) \<diamondop> (\<Phi>(g, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; R))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = \<^bold>R\<^sub>s ((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> ((P \<Rightarrow>\<^sub>r Q) \<triangleleft> \<lceil>g\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)) \<diamondop> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow>\<^sub>r R)))"
    by (simp add: Guard_tri_design rdes assms closure)
  also have "... = \<^bold>R\<^sub>s (([g]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> ((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> Q) \<or> \<E>(\<not>g,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u)) \<diamondop> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> R))"
    by (rel_auto)
  also have "... = \<^bold>R\<^sub>s (([g]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> ((\<Phi>(g, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; Q) \<or> \<E>(\<not>g,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u)) \<diamondop> (\<Phi>(g, id\<^sub>s, \<guillemotleft>[]\<guillemotright>) ;; R))"
    by (simp add: assms(2) assms(3) csp_do_cond_conj)
  finally show ?thesis .
qed

lemma Guard_rdes_def':
  assumes "$ok\<acute> \<sharp> P"
  shows "g &\<^sub>C (\<^bold>R\<^sub>s(P \<turnstile> Q)) = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> Q \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
proof -
  have "g &\<^sub>C (\<^bold>R\<^sub>s(P \<turnstile> Q)) = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R (\<^bold>R\<^sub>s (P \<turnstile> Q))) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> cmt\<^sub>R (\<^bold>R\<^sub>s (P \<turnstile> Q)) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
    by (simp add: GuardCSP_def)
  also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> R1(R2c(cmt\<^sub>s \<dagger> (P \<Rightarrow> Q))) \<or>  \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
    by (simp add: rea_pre_RHS_design rea_cmt_RHS_design)
  also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> R1(R2c(\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> R1(R2c(cmt\<^sub>s \<dagger> (P \<Rightarrow> Q))) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)))"
    by (metis (no_types, lifting) RHS_design_export_R1 RHS_design_export_R2c)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> R1(R2c(\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (cmt\<^sub>s \<dagger> (P \<Rightarrow> Q)) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)))"
     by (simp add: R1_R2c_commute R1_disj R1_extend_conj' R1_idem R2c_and R2c_disj R2c_idem)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (cmt\<^sub>s \<dagger> (P \<Rightarrow> Q)) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (metis (no_types, lifting) RHS_design_export_R1 RHS_design_export_R2c)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> cmt\<^sub>s \<dagger> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (cmt\<^sub>s \<dagger> (P \<Rightarrow> Q)) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (simp add: rdes_export_cmt)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> cmt\<^sub>s \<dagger> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (simp add: usubst)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r R1(R2c(pre\<^sub>s \<dagger> P))) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (simp add: rdes_export_cmt)
   also from assms have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r (pre\<^sub>s \<dagger> P)) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (rel_auto)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>s \<dagger> P)\<lbrakk>true,false/$ok,$wait\<rbrakk> \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (simp add: rdes_export_pre)
   also from assms have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P)\<lbrakk>true,false/$ok,$wait\<rbrakk> \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (rel_auto)
   also from assms have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> (P \<Rightarrow> Q) \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (simp add: rdes_export_pre)
   also have "... = \<^bold>R\<^sub>s((\<lceil>g\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P) \<turnstile> (\<lceil>g\<rceil>\<^sub>S\<^sub>< \<and> Q \<or> \<lceil>\<not>g\<rceil>\<^sub>S\<^sub>< \<and> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"
     by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
   finally show ?thesis .
qed

lemma CSP_Guard [closure]: "b &\<^sub>C P is CSP"
  by (simp add: GuardCSP_def, rule RHS_design_is_SRD, simp_all add: unrest)

lemma preR_Guard [rdes]: "P is CSP \<Longrightarrow> pre\<^sub>R(b &\<^sub>C P) = ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P)"
  by (simp add: Guard_tri_design rea_pre_RHS_design usubst unrest R2c_preR R2c_lift_state_pre
      R2c_rea_impl R1_rea_impl R1_preR Healthy_if, rel_auto)

lemma periR_Guard [rdes]:
  assumes "P is NCSP"
  shows "peri\<^sub>R(b &\<^sub>C P) = (peri\<^sub>R P \<triangleleft> b \<triangleright>\<^sub>R \<E>(true,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u))"
proof -
  have "peri\<^sub>R(b &\<^sub>C P) = ((\<lceil>b\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)))"
    by (simp add: assms Guard_tri_design rea_peri_RHS_design usubst unrest R1_rea_impl R2c_rea_not
        R2c_rea_impl R2c_preR R2c_periR R2c_tr'_minus_tr R2c_lift_state_pre R2c_condr closure
        Healthy_if R1_cond R1_tr'_eq_tr)
  also have "... = ((pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P) \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr))"
    by (rel_auto)
  also have "... = (peri\<^sub>R P \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr))"
    by (simp add: SRD_peri_under_pre add: unrest closure assms)
  finally show ?thesis
    by rel_auto
qed

lemma postR_Guard [rdes]:
  assumes "P is NCSP"
  shows "post\<^sub>R(b &\<^sub>C P) = ([b]\<^sub>S\<^sub>< \<and> post\<^sub>R P)"
proof -
  have "post\<^sub>R(b &\<^sub>C P) = ((\<lceil>b\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P) \<Rightarrow>\<^sub>r (\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> post\<^sub>R P))"
    by (simp add: Guard_tri_design rea_post_RHS_design usubst unrest R2c_rea_not R2c_and R2c_rea_impl
        R2c_preR R2c_postR R2c_tr'_minus_tr R2c_lift_state_pre R2c_condr R1_rea_impl R1_extend_conj'
        R1_post_SRD closure assms)
  also have "... = (\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P))"
    by (rel_auto)
  also have "... = (\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> post\<^sub>R P)"
    by (simp add: SRD_post_under_pre add: unrest closure assms)
  also have "... = ([b]\<^sub>S\<^sub>< \<and> post\<^sub>R P)"
    by (metis CSP_Guard R1_extend_conj R1_post_SRD calculation rea_st_cond_def)
  finally show ?thesis .
qed

lemma CSP3_Guard [closure]:
  assumes "P is CSP" "P is CSP3"
  shows "b &\<^sub>C P is CSP3"
proof -
  from assms have 1:"$ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>"
    by (simp add: CSP_Guard CSP3_iff)
  hence "$ref \<sharp> pre\<^sub>R (P\<lbrakk>0/$tr\<rbrakk>)" "$ref \<sharp> pre\<^sub>R P" "$ref \<sharp> cmt\<^sub>R P"
    by (pred_blast)+
  hence "$ref \<sharp> (b &\<^sub>C P)\<lbrakk>false/$wait\<rbrakk>"
    by (simp add: CSP3_iff GuardCSP_def RHS_def R1_def R2c_def R2s_def R3h_def design_def unrest usubst)
  thus ?thesis
    by (metis CSP3_intro CSP_Guard)
qed

lemma CSP4_Guard [closure]:
  assumes "P is NCSP"
  shows "b &\<^sub>C P is CSP4"
proof (rule CSP4_tri_intro[OF CSP_Guard])
  show "(\<not>\<^sub>r pre\<^sub>R (b &\<^sub>C P)) ;; R1 true = (\<not>\<^sub>r pre\<^sub>R (b &\<^sub>C P))"
  proof -
    have a:"(\<not>\<^sub>r pre\<^sub>R P) ;; R1 true = (\<not>\<^sub>r pre\<^sub>R P)"
      by (simp add: CSP4_neg_pre_unit assms closure)
    have "(\<not>\<^sub>r ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P)) ;; R1 true = (\<not>\<^sub>r ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P))"
    proof -
      have 1:"(\<not>\<^sub>r ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P)) = ([b]\<^sub>S\<^sub>< \<and> (\<not>\<^sub>r pre\<^sub>R P))"
        by (rel_auto)
      also have 2:"... = ([b]\<^sub>S\<^sub>< \<and> ((\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
        by (simp add: a)
      also have 3:"... = (\<not>\<^sub>r ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P)) ;; R1 true"
        by (rel_auto)
      finally show ?thesis ..
    qed
    thus ?thesis
      by (simp add: preR_Guard periR_Guard NSRD_CSP4_intro closure assms unrest)
  qed
  show "$st\<acute> \<sharp> peri\<^sub>R (b &\<^sub>C P)"
    by (simp add: preR_Guard periR_Guard NSRD_CSP4_intro closure assms unrest)
  show "$ref\<acute> \<sharp> post\<^sub>R (b &\<^sub>C P)"
    by (simp add: preR_Guard postR_Guard NSRD_CSP4_intro closure assms unrest)
qed

lemma NCSP_Guard [closure]:
  assumes "P is NCSP"
  shows "b &\<^sub>C P is NCSP"
proof -
  have "P is CSP"
    using NCSP_implies_CSP assms by blast
  then show ?thesis
    by (metis (no_types) CSP3_Guard CSP3_commutes_CSP4 CSP4_Guard CSP4_Idempotent CSP_Guard Healthy_Idempotent Healthy_def NCSP_def assms comp_apply)
qed

lemma Productive_Guard [closure]:
  assumes "P is CSP" "P is Productive" "$wait\<acute> \<sharp> pre\<^sub>R(P)"
  shows "b &\<^sub>C P is Productive"
proof -
  have "b &\<^sub>C P = b &\<^sub>C \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (metis Healthy_def Productive_form assms(1) assms(2))
  also have "... =
        \<^bold>R\<^sub>s ((\<lceil>b\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P) \<turnstile>
          ((pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P) \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)) \<diamondop> (\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr)))"
    by (simp add: Guard_tri_design rea_pre_RHS_design rea_peri_RHS_design rea_post_RHS_design unrest assms
        usubst R1_preR Healthy_if R1_rea_impl R1_peri_SRD R1_extend_conj' R2c_preR R2c_not R2c_rea_impl
        R2c_periR R2c_postR R2c_and R2c_tr_less_tr' R1_tr_less_tr')
  also have "... = \<^bold>R\<^sub>s ((\<lceil>b\<rceil>\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r pre\<^sub>R P) \<turnstile> (peri\<^sub>R P \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<triangleright> ($tr\<acute> =\<^sub>u $tr)) \<diamondop> ((\<lceil>b\<rceil>\<^sub>S\<^sub>< \<and> post\<^sub>R P) \<and> $tr\<acute> >\<^sub>u $tr))"
    by (rel_auto)
  also have "... = Productive(b &\<^sub>C P)"
    by (simp add: Productive_def Guard_tri_design RHS_tri_design_par unrest)
  finally show ?thesis
    by (simp add: Healthy_def')
qed

lemma Guard_refines_sinv:
  assumes "P is NCSP" "sinv\<^sub>R(b) \<sqsubseteq> P"
  shows "sinv\<^sub>R(b) \<sqsubseteq> g &\<^sub>C P"
proof -
  from assms
  have "\<^bold>R\<^sub>s([b]\<^sub>S\<^sub>< \<turnstile> R1 true \<diamondop> [b]\<^sub>S\<^sub>>) \<sqsubseteq> \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))"
    by (simp add: rdes_def NCSP_implies_CSP SRD_reactive_tri_design)
  thus ?thesis
    apply (simp add: RHS_tri_design_refine' closure unrest assms)
    apply (safe)
    apply (rdes_refine cls: assms(1))
    done
qed

subsection \<open> Basic events\<close>

definition do\<^sub>u ::
  "('\<phi>, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>, '\<phi>) action" where
[upred_defs]: "do\<^sub>u e = (($tr\<acute> =\<^sub>u $tr \<and> \<lceil>e\<rceil>\<^sub>S\<^sub>< \<notin>\<^sub>u $ref\<acute>) \<triangleleft> $wait\<acute> \<triangleright> U($tr\<acute> = $tr @ [\<lceil>e\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st))"

definition DoCSP :: "('\<phi>, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>, '\<phi>) action" ("do\<^sub>C") where
[upred_defs]: "DoCSP a = \<^bold>R\<^sub>s(true \<turnstile> do\<^sub>u a)"

lemma R1_DoAct: "R1(do\<^sub>u(a)) = do\<^sub>u(a)"
  by (rel_auto)

lemma R2c_DoAct: "R2c(do\<^sub>u(a)) = do\<^sub>u(a)"
  by (rel_auto)

lemma DoCSP_alt_def: "do\<^sub>C(a) = R3h(CSP1($ok\<acute> \<and> do\<^sub>u(a)))"
  apply (simp add: DoCSP_def RHS_def design_def impl_alt_def  R1_R3h_commute R2c_R3h_commute R2c_disj
                   R2c_not R2c_ok R2c_ok' R2c_and R2c_DoAct R1_disj R1_extend_conj' R1_DoAct)
  apply (rel_auto)
done

lemma DoAct_unrests [unrest]:
  "$ok \<sharp> do\<^sub>u(a)" "$wait \<sharp> do\<^sub>u(a)"
  by (pred_auto)+

lemma DoCSP_RHS_tri [rdes_def]:
  "do\<^sub>C(a) = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> (\<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u) \<diamondop> \<Phi>(true,id\<^sub>s,U([a]))))"
  by (simp add: DoCSP_def do\<^sub>u_def wait'_cond_def, rel_auto)

lemma CSP_DoCSP [closure]: "do\<^sub>C(a) is CSP"
  by (simp add: DoCSP_def do\<^sub>u_def RHS_design_is_SRD unrest)

lemma preR_DoCSP [rdes]: "pre\<^sub>R(do\<^sub>C(a)) = true\<^sub>r"
  by (simp add: DoCSP_def rea_pre_RHS_design unrest usubst R2c_true)

lemma periR_DoCSP [rdes]: "peri\<^sub>R(do\<^sub>C(a)) = \<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u)"
  by (rel_auto)

lemma postR_DoCSP [rdes]: "post\<^sub>R(do\<^sub>C(a)) = \<Phi>(true,id\<^sub>s,U([a]))"
  by (rel_auto)

lemma CSP3_DoCSP [closure]: "do\<^sub>C(a) is CSP3"
  by (rule CSP3_intro[OF CSP_DoCSP])
     (simp add: DoCSP_def do\<^sub>u_def RHS_def design_def R1_def R2c_def R2s_def R3h_def unrest usubst)

lemma CSP4_DoCSP [closure]: "do\<^sub>C(a) is CSP4"
  by (rule CSP4_tri_intro[OF CSP_DoCSP], simp_all add: preR_DoCSP periR_DoCSP postR_DoCSP unrest)

lemma NCSP_DoCSP [closure]: "do\<^sub>C(a) is NCSP"
  by (metis CSP3_DoCSP CSP4_DoCSP CSP_DoCSP Healthy_def NCSP_def comp_apply)

lemma Productive_DoCSP [closure]:
  "(do\<^sub>C a :: ('\<sigma>, '\<psi>) action) is Productive"
proof -
  have "((\<Phi>(true,id\<^sub>s,U([a])) \<and> $tr\<acute> >\<^sub>u $tr) :: ('\<sigma>, '\<psi>) action)
        = (\<Phi>(true,id\<^sub>s,U([a])))"
    by (rel_auto, simp add: Prefix_Order.strict_prefixI')
  hence "Productive(do\<^sub>C a) = do\<^sub>C a"
    by (simp add: Productive_RHS_design_form DoCSP_RHS_tri unrest)
  thus ?thesis
    by (simp add: Healthy_def)
qed

lemma PCSP_DoCSP [closure]:
  "(do\<^sub>C a :: ('\<sigma>, '\<psi>) action) is PCSP"
  by (simp add: Healthy_comp NCSP_DoCSP Productive_DoCSP)

lemma wp_rea_DoCSP_lemma:
  fixes P :: "('\<sigma>, '\<phi>) action"
  assumes "$ok \<sharp> P" "$wait \<sharp> P"
  shows "U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st) ;; P = (\<exists> $ref \<bullet> P\<lbrakk>U($tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><])/$tr\<rbrakk>)"
  using assms
  by (rel_auto, meson)

lemma wp_rea_DoCSP:
  assumes "P is NCSP"
  shows "U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st) wp\<^sub>r pre\<^sub>R P =
         (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P)\<lbrakk>U($tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><])/$tr\<rbrakk>)"
  by (simp add: wp_rea_def wp_rea_DoCSP_lemma unrest usubst ex_unrest assms closure)

lemma wp_rea_DoCSP_alt:
  assumes "P is NCSP"
  shows "U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st) wp\<^sub>r pre\<^sub>R P =
         U($tr\<acute> \<ge> $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<Rightarrow>\<^sub>r (pre\<^sub>R P)\<lbrakk>$tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><]/$tr\<rbrakk>)"
  by (simp add: wp_rea_DoCSP assms rea_not_def R1_def usubst unrest, rel_auto)

lemma DoCSP_refine_sinv: "sinv\<^sub>R(b) \<sqsubseteq> do\<^sub>C(a)"
  by (rdes_refine)

subsection \<open> Event prefix \<close>

definition PrefixCSP ::
  "('\<phi>, '\<sigma>) uexpr \<Rightarrow>
  ('\<sigma>, '\<phi>) action \<Rightarrow>
  ('\<sigma>, '\<phi>) action" ("_ \<rightarrow>\<^sub>C _" [81, 80] 80) where
[upred_defs]: "PrefixCSP a P = (do\<^sub>C(a) ;; CSP(P))"

abbreviation "OutputCSP c v P \<equiv> PrefixCSP (c\<cdot>v)\<^sub>u P"

lemma CSP_PrefixCSP [closure]: "PrefixCSP a P is CSP"
  by (simp add: PrefixCSP_def closure)

lemma CSP3_PrefixCSP [closure]:
  "PrefixCSP a P is CSP3"
  by (metis (no_types, opaque_lifting) CSP3_DoCSP CSP3_def Healthy_def PrefixCSP_def seqr_assoc)

lemma CSP4_PrefixCSP [closure]:
  assumes "P is CSP" "P is CSP4"
  shows "PrefixCSP a P is CSP4"
  by (metis (no_types, opaque_lifting) CSP4_def Healthy_def PrefixCSP_def assms(1) assms(2) seqr_assoc)

lemma NCSP_PrefixCSP [closure]:
  assumes "P is NCSP"
  shows "PrefixCSP a P is NCSP"
  by (metis (no_types, opaque_lifting) CSP3_PrefixCSP CSP3_commutes_CSP4 CSP4_Idempotent CSP4_PrefixCSP
            CSP_PrefixCSP Healthy_Idempotent Healthy_def NCSP_def NCSP_implies_CSP assms comp_apply)

lemma Productive_PrefixCSP [closure]: "P is NCSP \<Longrightarrow> PrefixCSP a P is Productive"
  by (simp add: Healthy_if NCSP_DoCSP NCSP_implies_NSRD NSRD_is_SRD PrefixCSP_def Productive_DoCSP Productive_seq_1)

lemma PCSP_PrefixCSP [closure]: "P is NCSP \<Longrightarrow> PrefixCSP a P is PCSP"
  by (simp add: Healthy_comp NCSP_PrefixCSP Productive_PrefixCSP)

lemma PrefixCSP_Guarded [closure]: "Guarded (PrefixCSP a)"
proof -
  have "PrefixCSP a = (\<lambda> X. do\<^sub>C(a) ;; CSP(X))"
    by (simp add: fun_eq_iff PrefixCSP_def)
  thus ?thesis
    using Guarded_if_Productive NCSP_DoCSP NCSP_implies_NSRD Productive_DoCSP by auto
qed

lemma PrefixCSP_type [closure]: "PrefixCSP a \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>CSP\<rbrakk>\<^sub>H"
  using CSP_PrefixCSP by blast

lemma PrefixCSP_Continuous [closure]: "Continuous (PrefixCSP a)"
  by (simp add: Continuous_def PrefixCSP_def ContinuousD[OF SRD_Continuous] seq_Sup_distl)

lemma PrefixCSP_RHS_tri_lemma1:
  "R1 (R2s (U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><]) \<and> \<lceil>II\<rceil>\<^sub>R)) = (U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><]) \<and> \<lceil>II\<rceil>\<^sub>R)"
  by (rel_auto)

lemma PrefixCSP_RHS_tri_lemma2:
  fixes P :: "('\<sigma>, '\<phi>) action"
  assumes "$ok \<sharp> P" "$wait \<sharp> P"
  shows "(U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st) \<and> \<not> $wait\<acute>) ;; P = (\<exists> $ref \<bullet> P\<lbrakk>U($tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><])/$tr\<rbrakk>)"
  using assms
  by (rel_auto, meson, fastforce)

lemma tr_extend_seqr:
  fixes P :: "('\<sigma>, '\<phi>) action"
  assumes "$ok \<sharp> P" "$wait \<sharp> P" "$ref \<sharp> P"
  shows "U($tr\<acute> = $tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><] \<and> $st\<acute> = $st) ;; P = P\<lbrakk>U($tr @ [\<lceil>a\<rceil>\<^sub>S\<^sub><])/$tr\<rbrakk>"
  using assms by (simp add: wp_rea_DoCSP_lemma assms unrest ex_unrest)

lemma trace_ext_R1_closed [closure]: "P is R1 \<Longrightarrow> P\<lbrakk>$tr ^\<^sub>u e/$tr\<rbrakk> is R1"
  by (rel_blast)

lemma preR_PrefixCSP_NCSP [rdes]:
  assumes "P is NCSP"
  shows "pre\<^sub>R(PrefixCSP a P) = (\<Phi>(true,id\<^sub>s,U([a])) wp\<^sub>r pre\<^sub>R P)"
  by (simp add: PrefixCSP_def assms closure rdes rpred Healthy_if wp usubst unrest)

(*
lemma periR_PrefixCSP [rdes]:
  assumes "P is NCSP"
  shows "peri\<^sub>R(PrefixCSP a P) = (\<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u) \<or> (peri\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
proof -
  have "peri\<^sub>R(PrefixCSP a P) =  peri\<^sub>R (do\<^sub>C a ;; P)"
    by (simp add: PrefixCSP_def closure assms Healthy_if)
  also have "... = undefined"
    apply (simp add: rdes closure assms rpred)
  also have "... = ((\<Phi>(true,id,\<langle>a\<rangle>) wp\<^sub>r pre\<^sub>R P) \<Rightarrow>\<^sub>r $tr\<acute> =\<^sub>u $tr \<and> \<lceil>a\<rceil>\<^sub>S\<^sub>< \<notin>\<^sub>u $ref\<acute> \<or> peri\<^sub>R P\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
    by (simp add: assms NSRD_CSP4_intro csp_enable_tr_empty closure rdes unrest ex_unrest usubst rpred csp_do_comp wp)
  also have "... = (\<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u) \<or> ((\<Phi>(true,id,\<langle>a\<rangle>) wp\<^sub>r pre\<^sub>R P) \<Rightarrow>\<^sub>r peri\<^sub>R P\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t))"
    by (rel_auto)
  also have "... = (\<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u) \<or> ((pre\<^sub>R(P) \<Rightarrow>\<^sub>r peri\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t))"
    by (rel_auto)
  also have "... = (\<E>(true,\<guillemotleft>[]\<guillemotright>,{a}\<^sub>u) \<or> (peri\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
    by (simp add: SRD_peri_under_pre assms closure unrest)
  finally show ?thesis .
qed

lemma postR_PrefixCSP [rdes]:
  assumes "P is NCSP"
  shows "post\<^sub>R(PrefixCSP a P) = (post\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t"
proof -
  have "post\<^sub>R(PrefixCSP a P) = ((\<I>(true,\<langle>a\<rangle>) \<Rightarrow>\<^sub>r (pre\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t) \<Rightarrow>\<^sub>r (post\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
    by (simp add: PrefixCSP_def assms Healthy_if)
       (simp add: assms Healthy_if wp closure rdes rpred wp_rea_DoCSP_lemma unrest  ex_unrest usubst)
  also have "... = (\<I>(true,\<langle>a\<rangle>) \<and> (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
    by (rel_auto)
  also have "... = (\<I>(true,\<langle>a\<rangle>) \<and> (post\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
    by (simp add: SRD_post_under_pre assms closure unrest)
  also have "... = (post\<^sub>R P)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t"
    by (rel_auto)
  finally show ?thesis .
qed
*)

lemma PrefixCSP_RHS_tri:
  assumes "P is NCSP"
  shows "PrefixCSP a P = \<^bold>R\<^sub>s (\<Phi>(true,id\<^sub>s,U([a])) wp\<^sub>r pre\<^sub>R P \<turnstile> (\<E>(true,\<guillemotleft>[]\<guillemotright>, {a}\<^sub>u) \<or> \<Phi>(true,id\<^sub>s,U([a])) ;; peri\<^sub>R P) \<diamondop> \<Phi>(true,id\<^sub>s,U([a])) ;; post\<^sub>R P)"
  by (simp add: PrefixCSP_def Healthy_if unrest assms closure NSRD_composition_wp rdes rpred usubst wp)

text \<open> For prefix, we can chose whether to propagate the assumptions or not, hence there
  are two laws. \<close>

lemma PrefixCSP_rdes_def_1 [rdes_def]:
  assumes "P is CRC" "Q is CRR" "R is CRR"
          "$st\<acute> \<sharp> Q" "$ref\<acute> \<sharp> R"
        shows "PrefixCSP a (\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) =
               \<^bold>R\<^sub>s (\<Phi>(true,id\<^sub>s,U([a])) wp\<^sub>r P \<turnstile> (\<E>(true,\<guillemotleft>[]\<guillemotright>, {a}\<^sub>u) \<or> \<Phi>(true,id\<^sub>s,U([a])) ;; Q) \<diamondop> \<Phi>(true,id\<^sub>s,U([a])) ;; R)"
  by (simp add: PrefixCSP_def Healthy_if assms closure, rdes_simp cls: assms)

(*
lemma PrefixCSP_rdes_def_2:
  assumes "P is CRC" "Q is CRR" "R is CRR"
          "$st\<acute> \<sharp> Q" "$ref\<acute> \<sharp> R"
  shows "PrefixCSP a (\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) = \<^bold>R\<^sub>s((\<I>(true,\<langle>a\<rangle>) \<Rightarrow>\<^sub>r P\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t) \<turnstile> (\<E>(true,\<guillemotleft>[]\<guillemotright>, {a}\<^sub>u) \<or> (P\<and>Q)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t) \<diamondop> (P\<and>R)\<lbrakk>\<langle>a\<rangle>\<rbrakk>\<^sub>t)"
  apply (subst PrefixCSP_RHS_tri)
   apply (rule NCSP_rdes_intro)
       apply (simp_all add: assms rdes closure)
  apply (rel_auto)
  done
*)

subsection \<open> Guarded external choice \<close>

abbreviation GuardedChoiceCSP :: "'\<theta> set \<Rightarrow> ('\<theta> \<Rightarrow> ('\<sigma>, '\<theta>) action) \<Rightarrow> ('\<sigma>, '\<theta>) action" where
"GuardedChoiceCSP A P \<equiv> (\<box> x\<in>A \<bullet> PrefixCSP \<guillemotleft>x\<guillemotright> (P(x)))"

syntax
  "_GuardedChoiceCSP" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<box> _ \<in> _ \<^bold>\<rightarrow> _" [0,0,85] 86)

translations
  "\<box> x\<in>A \<^bold>\<rightarrow> P" == "CONST GuardedChoiceCSP A (\<lambda> x. P)"

lemma GuardedChoiceCSP [rdes_def]:
  assumes "\<And> x. P(x) is NCSP" "A \<noteq> {}"
  shows "(\<box> x\<in>A \<^bold>\<rightarrow> P(x)) =
             \<^bold>R\<^sub>s ((\<Squnion> x \<in> A \<bullet> \<Phi>(true,id\<^sub>s,\<guillemotleft>[x]\<guillemotright>) wp\<^sub>r pre\<^sub>R (P x)) \<turnstile>
                 ((\<Squnion> x \<in> A \<bullet> \<E>(true,\<guillemotleft>[]\<guillemotright>, {\<guillemotleft>x\<guillemotright>}\<^sub>u)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> x \<in> A \<bullet> \<Phi>(true,id\<^sub>s,\<guillemotleft>[x]\<guillemotright>) ;; peri\<^sub>R (P x))) \<diamondop>
                  (\<Sqinter> x \<in> A \<bullet> \<Phi>(true,id\<^sub>s,\<guillemotleft>[x]\<guillemotright>) ;; post\<^sub>R (P x)))"
  by (simp add: PrefixCSP_RHS_tri assms ExtChoice_tri_rdes closure unrest, rel_auto)

subsection \<open> Input prefix \<close>

definition InputCSP ::
  "('a, '\<theta>) chan \<Rightarrow> ('a \<Rightarrow> '\<sigma> upred) \<Rightarrow> ('a \<Rightarrow> ('\<sigma>, '\<theta>) action) \<Rightarrow> ('\<sigma>, '\<theta>) action" where
[upred_defs]: "InputCSP c A P = (\<box> x\<in>UNIV \<bullet> A(x) &\<^sub>C PrefixCSP (c\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u (P x))"

definition InputVarCSP :: "('a, '\<theta>) chan \<Rightarrow> ('a \<Longrightarrow> '\<sigma>) \<Rightarrow> ('a \<Rightarrow> '\<sigma> upred) \<Rightarrow> ('\<sigma>, '\<theta>) action" where
[upred_defs, rdes_def]: "InputVarCSP c x A = InputCSP c A (\<lambda> v. \<langle>[x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>]\<rangle>\<^sub>C)"

definition do\<^sub>I :: "
  ('a, '\<theta>) chan \<Rightarrow>
  ('a \<Longrightarrow> ('\<sigma>, '\<theta>) sfrd) \<Rightarrow>
  ('a \<Rightarrow> ('\<sigma>, '\<theta>) action) \<Rightarrow>
  ('\<sigma>, '\<theta>) action" where
"do\<^sub>I c x P = (
  ($tr\<acute> =\<^sub>u $tr \<and> {e | P(e) \<bullet> (c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u} \<inter>\<^sub>u $ref\<acute> =\<^sub>u {}\<^sub>u)
    \<triangleleft> $wait\<acute> \<triangleright>
  (($tr\<acute> - $tr) \<in>\<^sub>u {e | P(e) \<bullet> U([(c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u])} \<and> (c\<cdot>$x\<acute>)\<^sub>u =\<^sub>u last\<^sub>u($tr\<acute>)))"

lemma InputCSP_CSP [closure]: "InputCSP c A P is CSP"
  by (simp add: CSP_ExtChoice InputCSP_def)

lemma InputCSP_NCSP [closure]: "\<lbrakk> \<And> v. P(v) is NCSP \<rbrakk> \<Longrightarrow> InputCSP c A P is NCSP"
  apply (simp add: InputCSP_def)
  apply (rule NCSP_ExtChoice)
  apply (simp add: NCSP_Guard NCSP_PrefixCSP image_Collect_subsetI top_set_def)
  done

lemma InputVarCSP_NCSP [closure]: "InputVarCSP c x A is NCSP"
  by (simp add: AssignsCSP_NCSP InputCSP_NCSP InputVarCSP_def)

lemma Productive_InputCSP [closure]:
  "\<lbrakk> \<And> v. P(v) is NCSP \<rbrakk> \<Longrightarrow> InputCSP x A P is Productive"
  by (auto simp add: InputCSP_def unrest closure intro: Productive_ExtChoice)

lemma Productive_InputVarCSP [closure]: "InputVarCSP c x A is Productive"
  by (simp add: InputVarCSP_def closure)

(*
lemma preR_InputCSP [rdes]:
  assumes "\<And> v. P(v) is NCSP"
  shows "pre\<^sub>R(InputCSP a A P) = (\<Squnion> v \<bullet> [A(v)]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<I>(true,\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>) \<Rightarrow>\<^sub>r (pre\<^sub>R (P(v)))\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)"
  by (simp add: InputCSP_def rdes closure assms alpha usubst unrest)

lemma periR_InputCSP [rdes]:
  assumes "\<And> v. P(v) is NCSP"
  shows "peri\<^sub>R(InputCSP a A P) =
           ((\<Squnion> x \<bullet> [A(x)]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<E>(true, \<guillemotleft>[]\<guillemotright>, {(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u)))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright>
            (\<Sqinter> x \<bullet> [A(x)]\<^sub>S\<^sub>< \<and> (peri\<^sub>R (P x))\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)"
  by (simp add: InputCSP_def rdes closure assms, rel_auto)

lemma postR_InputCSP [rdes]:
  assumes "\<And> v. P(v) is NCSP"
  shows "post\<^sub>R(InputCSP a A P) =
          (\<Sqinter> x \<bullet> [A x]\<^sub>S\<^sub>< \<and> post\<^sub>R (P x)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)"
  using assms by (simp add: InputCSP_def rdes closure assms usubst unrest)
*)

lemma R4_st_pred_conj_do [rpred]:
  "((R4 [s\<^sub>1]\<^sub>S\<^sub><) \<and> \<Phi>(s\<^sub>2,\<sigma>,t) ;; P) = R4(\<Phi>(s\<^sub>1 \<and> s\<^sub>2,\<sigma>,t) ;; P) "
  by (rel_auto)

lemma unrest_ref'_R4 [unrest]: "$ref\<acute> \<sharp> P \<Longrightarrow> $ref\<acute> \<sharp> R4(P)"
  by (simp add: R4_def unrest)

lemma st_pred_conj_seq [rpred]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> ([s]\<^sub>S\<^sub>< \<and> P ;; Q) = (([s]\<^sub>S\<^sub>< \<and> P) ;; Q)"
  by (metis (no_types, lifting) R1_seqr_closure RR_implies_R1 cond_st_distr cond_st_miracle seqr_left_zero)

lemma InputCSP_rdes_def [rdes_def]:
  assumes "\<And> v. P(v) is CRC" "\<And> v. Q(v) is CRR" "\<And> v. R(v) is CRR"
          "\<And> v. $st\<acute> \<sharp> Q(v)" "\<And> v. $ref\<acute> \<sharp> R(v)"
  shows "InputCSP a A (\<lambda> v. \<^bold>R\<^sub>s(P(v) \<turnstile> Q(v) \<diamondop> R(v))) =
           \<^bold>R\<^sub>s((\<Squnion> x \<bullet> \<Phi>(A x,id\<^sub>s,U([(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u])) wp\<^sub>r P x) \<turnstile>
             ((\<Squnion> x \<bullet> \<E>(A x,\<guillemotleft>[]\<guillemotright>, {(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u) \<or> \<E>(\<not> A x,\<guillemotleft>[]\<guillemotright>, {}\<^sub>u)) \<or> (\<Sqinter> x \<bullet> \<Phi>(A x,id\<^sub>s,U([(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u])) ;; Q x)) \<diamondop>
             (\<Sqinter> x \<bullet> \<Phi>(A x,id\<^sub>s,U([(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u])) ;; R x))"
  by (simp add: InputCSP_def, rdes_simp cls: assms)

(*
lemma InputCSP_rdes_def [rdes_def]:
  assumes "\<And> v. P(v) is CRC" "\<And> v. Q(v) is CRR" "\<And> v. R(v) is CRR"
          "\<And> v. $st\<acute> \<sharp> Q(v)" "\<And> v. $ref\<acute> \<sharp> R(v)"
  shows "InputCSP a A (\<lambda> v. \<^bold>R\<^sub>s(P(v) \<turnstile> Q(v) \<diamondop> R(v))) =
         \<^bold>R\<^sub>s( (\<Squnion> v \<bullet> ([A(v)]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<I>(true,\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>) \<Rightarrow>\<^sub>r (P v)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t))
           \<turnstile> (((\<Squnion> x \<bullet> R5([A(x)]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<E>(true, \<guillemotleft>[]\<guillemotright>, {(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u))))
               \<or>
               (\<Sqinter> x \<bullet> [A(x)]\<^sub>S\<^sub>< \<and> (P x \<and> Q x)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t))
           \<diamondop> (\<Sqinter> x \<bullet> [A x]\<^sub>S\<^sub>< \<and> (P x \<and> R x)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t))" (is "?lhs = ?rhs")
proof -
  have 1:"pre\<^sub>R(?lhs) = (\<Squnion> v \<bullet> [A v]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<I>(true,\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>) \<Rightarrow>\<^sub>r P v\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>v\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)" (is "_ = ?A")
    by (simp add: rdes NCSP_rdes_intro assms conj_comm closure)
  have 2:"peri\<^sub>R(?lhs) = (\<Squnion> x \<bullet> [A x]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r \<E>(true,\<guillemotleft>[]\<guillemotright>, {(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> x \<bullet> [A x]\<^sub>S\<^sub>< \<and> (P x \<Rightarrow>\<^sub>r Q x)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)"
    (is "_ = ?B")
    by (simp add: rdes NCSP_rdes_intro assms closure)
  have 3:"post\<^sub>R(?lhs) = (\<Sqinter> x \<bullet> [A x]\<^sub>S\<^sub>< \<and> (P x \<Rightarrow>\<^sub>r R x)\<lbrakk>\<langle>(a\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle>\<rbrakk>\<^sub>t)"
    (is "_ = ?C")
    by (simp add: rdes NCSP_rdes_intro assms closure)
  have "?lhs = \<^bold>R\<^sub>s(?A \<turnstile> ?B \<diamondop> ?C)"
    by (subst SRD_reactive_tri_design[THEN sym], simp_all add: closure 1 2 3)
  also have "... = ?rhs"
    by (rel_auto)
  finally show ?thesis .
qed
*)

subsection \<open> Renaming \<close>

definition RenameCSP :: "('s, 'e) action \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> ('s, 'f) action" ("(_)\<lparr>_\<rparr>\<^sub>C" [999, 0] 999) where
[upred_defs]: "RenameCSP P f = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P))\<lparr>f\<rparr>\<^sub>c ;; true\<^sub>r) \<turnstile> ((peri\<^sub>R(P))\<lparr>f\<rparr>\<^sub>c) \<diamondop> ((post\<^sub>R(P))\<lparr>f\<rparr>\<^sub>c))"

lemma RenameCSP_rdes_def [rdes_def]:
  assumes "P is CRC" "Q is CRR" "R is CRR"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<lparr>f\<rparr>\<^sub>C = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r P)\<lparr>f\<rparr>\<^sub>c ;; true\<^sub>r) \<turnstile> Q\<lparr>f\<rparr>\<^sub>c \<diamondop> R\<lparr>f\<rparr>\<^sub>c)" (is "?lhs = ?rhs")
proof -
  have "?lhs =  \<^bold>R\<^sub>s ((\<not>\<^sub>r (\<not>\<^sub>r P)\<lparr>f\<rparr>\<^sub>c ;; true\<^sub>r) \<turnstile> (P \<Rightarrow>\<^sub>r Q)\<lparr>f\<rparr>\<^sub>c \<diamondop> (P \<Rightarrow>\<^sub>r R)\<lparr>f\<rparr>\<^sub>c)"
    by (simp add: RenameCSP_def rdes closure assms)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r (\<not>\<^sub>r CRC(P))\<lparr>f\<rparr>\<^sub>c ;; true\<^sub>r) \<turnstile> (CRC(P) \<Rightarrow>\<^sub>r CRR(Q))\<lparr>f\<rparr>\<^sub>c \<diamondop> (CRC(P) \<Rightarrow>\<^sub>r CRR(R))\<lparr>f\<rparr>\<^sub>c)"
    by (simp add: Healthy_if assms)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r (\<not>\<^sub>r CRC(P))\<lparr>f\<rparr>\<^sub>c ;; true\<^sub>r) \<turnstile> (CRR(Q))\<lparr>f\<rparr>\<^sub>c \<diamondop> (CRR(R))\<lparr>f\<rparr>\<^sub>c)"
    by (rel_auto, (metis order_refl)+)
  also have "... = ?rhs"
    by (simp add: Healthy_if assms)
  finally show ?thesis .
qed

lemma RenameCSP_pre_CRC_closed:
  assumes "P is CRR"
  shows "\<not>\<^sub>r (\<not>\<^sub>r P)\<lparr>f\<rparr>\<^sub>c ;; R1 true is CRC"
  apply (rule CRC_intro'')
   apply (simp add: unrest closure assms)
  apply (simp add: Healthy_def, simp add: RC1_def rpred closure CRC_idem assms seqr_assoc)
  done

lemma RenameCSP_NCSP_closed [closure]:
  assumes "P is NCSP"
  shows "P\<lparr>f\<rparr>\<^sub>C is NCSP"
  by (simp add: RenameCSP_def RenameCSP_pre_CRC_closed closure assms unrest)

lemma csp_rename_false [rpred]:
  "false\<lparr>f\<rparr>\<^sub>c = false"
  by (rel_auto)

lemma umap_nil [simp]: "map\<^sub>u f \<guillemotleft>[]\<guillemotright> = \<guillemotleft>[]\<guillemotright>"
  by (rel_auto)

lemma rename_Skip: "Skip\<lparr>f\<rparr>\<^sub>C = Skip"
  by (rdes_eq)

lemma rename_Chaos: "Chaos\<lparr>f\<rparr>\<^sub>C = Chaos"
  by (rdes_eq_split; rel_simp; force)

lemma rename_Miracle: "Miracle\<lparr>f\<rparr>\<^sub>C = Miracle"
  by (rdes_eq)

lemma rename_DoCSP: "(do\<^sub>C(a))\<lparr>f\<rparr>\<^sub>C = do\<^sub>C(\<guillemotleft>f\<guillemotright>(a)\<^sub>a)"
  by (rdes_eq)

subsection \<open> Algebraic laws \<close>

lemma AssignCSP_conditional:
  assumes "vwb_lens x"
  shows "x :=\<^sub>C e \<triangleleft> b \<triangleright>\<^sub>R x :=\<^sub>C f = x :=\<^sub>C (e \<triangleleft> b \<triangleright> f)"
  by (rdes_eq cls: assms)

lemma AssignsCSP_id: "\<langle>id\<^sub>s\<rangle>\<^sub>C = Skip"
  by (rel_auto)

lemma Guard_comp:
  "g &\<^sub>C h &\<^sub>C P = (g \<and> h) &\<^sub>C P"
  by (rule antisym, rel_blast, rel_blast)

lemma Guard_false [simp]: "false &\<^sub>C P = Stop"
  by (simp add: GuardCSP_def Stop_def rpred closure alpha R1_design_R1_pre)

lemma Guard_true [simp]:
  "P is CSP \<Longrightarrow> true &\<^sub>C P = P"
  by (simp add: GuardCSP_def alpha SRD_reactive_design_alt closure rpred)

lemma Guard_conditional:
  assumes "P is NCSP"
  shows "b &\<^sub>C P = P \<triangleleft> b \<triangleright>\<^sub>R Stop"
  by (rdes_eq cls: assms)

lemma Guard_expansion:
  assumes "P is NCSP"
  shows "(g\<^sub>1 \<or> g\<^sub>2) &\<^sub>C P = (g\<^sub>1 &\<^sub>C P) \<box> (g\<^sub>2 &\<^sub>C P)"
  apply (rdes_eq_split cls: assms)
    apply (rel_simp', fastforce simp add: dual_order.order_iff_strict)
   apply (rel_simp', simp add: dual_order.order_iff_strict, fastforce)
  apply (rel_simp', simp add: dual_order.order_iff_strict, fastforce)
  done

lemma Conditional_as_Guard:
  assumes "P is NCSP" "Q is NCSP"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q = b &\<^sub>C P \<box> (\<not> b) &\<^sub>C Q"
  by (rdes_eq' cls: assms; simp add: le_less)

lemma PrefixCSP_dist:
  "PrefixCSP a (P \<sqinter> Q) = (PrefixCSP a P) \<sqinter> (PrefixCSP a Q)"
  using Continuous_Disjunctous Disjunctuous_def PrefixCSP_Continuous by auto

lemma DoCSP_is_Prefix:
  "do\<^sub>C(a) = PrefixCSP a Skip"
  by (simp add: PrefixCSP_def Healthy_if closure, metis CSP4_DoCSP CSP4_def Healthy_def)

lemma PrefixCSP_seq:
  assumes "P is CSP" "Q is CSP"
  shows "(PrefixCSP a P) ;; Q = (PrefixCSP a (P ;; Q))"
  by (simp add: PrefixCSP_def seqr_assoc Healthy_if assms closure)

lemma PrefixCSP_extChoice_dist:
  assumes "P is NCSP" "Q is NCSP" "R is NCSP"
  shows "((a \<rightarrow>\<^sub>C P) \<box> (b \<rightarrow>\<^sub>C Q)) ;; R  = (a \<rightarrow>\<^sub>C P ;; R) \<box> (b \<rightarrow>\<^sub>C Q ;; R)"
  by (simp add: PCSP_PrefixCSP assms(1) assms(2) assms(3) extChoice_seq_distr)

lemma GuardedChoiceCSP_dist:
  assumes "\<And> i. i\<in>A \<Longrightarrow> P(i) is NCSP" "Q is NCSP"
  shows "\<box> x\<in>A \<^bold>\<rightarrow> P(x) ;; Q = \<box> x\<in>A \<^bold>\<rightarrow> (P(x) ;; Q)"
  by (simp add: ExtChoice_seq_distr PrefixCSP_seq closure assms cong: ExtChoice_cong)

text \<open> Alternation can be re-expressed as an external choice when the guards are disjoint \<close>

declare ExtChoice_tri_rdes [rdes_def]
declare ExtChoice_tri_rdes' [rdes_def del]

declare extChoice_rdes_def [rdes_def]
declare extChoice_rdes_def' [rdes_def del]

lemma AlternateR_as_ExtChoice:
  assumes
    "\<And> i. i \<in> A \<Longrightarrow> P(i) is NCSP" "Q is NCSP"
    "\<And> i j. \<lbrakk> i \<in> A; j \<in> A; i \<noteq> j \<rbrakk> \<Longrightarrow> (g i \<and> g j) = false"
  shows "(if\<^sub>R i\<in>A \<bullet> g(i) \<rightarrow> P(i) else Q fi) =
         (\<box> i\<in>A \<bullet> g(i) &\<^sub>C P(i)) \<box> (\<And> i\<in>A \<bullet> \<not> g(i)) &\<^sub>C Q"
proof (cases "A = {}")
  case True
  then show ?thesis by (simp add: ExtChoice_empty extChoice_Stop closure assms)
next
  case False
  show ?thesis

  proof -
    have 1:"(\<Sqinter> i \<in> A \<bullet> g i \<rightarrow>\<^sub>R P i) = (\<Sqinter> i \<in> A \<bullet> g i \<rightarrow>\<^sub>R \<^bold>R\<^sub>s(pre\<^sub>R(P i) \<turnstile> peri\<^sub>R(P i) \<diamondop> post\<^sub>R(P i)))"
      by (rule UINF_cong, simp add: NCSP_implies_CSP SRD_reactive_tri_design assms(1))
    have 2:"(\<box> i\<in>A \<bullet> g(i) &\<^sub>C P(i)) = (\<box> i\<in>A \<bullet> g(i) &\<^sub>C \<^bold>R\<^sub>s(pre\<^sub>R(P i) \<turnstile> peri\<^sub>R(P i) \<diamondop> post\<^sub>R(P i)))"
      by (rule ExtChoice_cong, simp add: NCSP_implies_NSRD NSRD_is_SRD SRD_reactive_tri_design assms(1))
    from assms(3) show ?thesis
      by (simp add: AlternateR_def 1 2)
         (rdes_eq' cls: assms(1-2) simps: False cong: UINF_cong USUP_cong ExtChoice_cong)
  qed
qed

declare ExtChoice_tri_rdes [rdes_def del]
declare ExtChoice_tri_rdes' [rdes_def]

declare extChoice_rdes_def [rdes_def del]
declare extChoice_rdes_def' [rdes_def]

find_theorems R4

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      ProcParEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2007-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header "Examples for Procedures as Parameters using Statespaces"
theory ProcParExSP imports "../Vcg" begin

lemma conseq_exploit_pre':
             "\<lbrakk>\<forall>s \<in> S. \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile> (P \<inter> S)c Q,A"
  apply (rule HoarePartialDef.Conseq)
  apply clarify
  by (metis IntI insertI1 subset_refl)

lemma conseq_exploit_pre'':
             "\<lbrakk>\<forall>Z. \<forall>s \<in> S Z.  \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P Z) c (Q Z),(A Z)\<rbrakk>
              \<Longrightarrow>
              \<forall>Z. \<Gamma>,\<Theta>\<turnstile> (P Z \<inter> S Z)c (Q Z),(A Z)"
  apply (rule allI)
  apply (rule conseq_exploit_pre')
  apply blast
  done

lemma conseq_exploit_pre''':
             "\<lbrakk>\<forall>s \<in> S. \<forall>Z. \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P Z) c (Q Z),(A Z)\<rbrakk>
              \<Longrightarrow>
              \<forall>Z. \<Gamma>,\<Theta>\<turnstile> (P Z \<inter> S)c (Q Z),(A Z)"
  apply (rule allI)
  apply (rule conseq_exploit_pre')
  apply blast
  done

procedures compare(i::nat,j::nat|r::bool) "NoBody"

print_locale! compare_signature

context compare_impl
begin
declare [[hoare_use_call_tr' = false]]
term "\<acute>r :== CALL compare(\<acute>i,\<acute>j)"
declare [[hoare_use_call_tr' = true]]
end

(* FIXME: typing issue with modifies locale*)
procedures
  LEQ (i::nat,j::nat | r::bool) "\<acute>r :== \<acute>i \<le> \<acute>j"
  LEQ_spec: "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>}  PROC LEQ(\<acute>i,\<acute>j,\<acute>r) \<lbrace>\<acute>r = (\<^bsup>\<sigma>\<^esup>i \<le> \<^bsup>\<sigma>\<^esup>j)\<rbrace>"

  LEQ_modifies: "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} PROC LEQ(\<acute>i,\<acute>j,\<acute>r) {t. t may_only_modify_globals \<sigma> in []}"

definition mx:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "mx leq a b = (if leq a b then a else b)"

procedures (imports compare_signature)
  Max (compare::string, n::nat, m::nat | k::nat)
  where b::bool
  in
  "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m);;
   IF \<acute>b THEN \<acute>k :== \<acute>n ELSE \<acute>k :== \<acute>m FI"

  Max_spec: "\<And>leq. \<forall>\<sigma>. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> {s. (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
              (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})})
    PROC Max(\<acute>compare,\<acute>n,\<acute>m,\<acute>k)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"

context Max_spec
begin
thm Max_spec
end
context Max_impl
begin
term "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m)"
declare [[hoare_use_call_tr' = false]]
term "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m)"
declare [[hoare_use_call_tr' = true]]
end

lemma (in Max_impl ) Max_spec1:
shows
"\<forall>\<sigma> leq. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> \<lbrace> (\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
      (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
proof -
  fix \<sigma>:: "('a, 'b, 'c, 'd) stateSP_scheme" and s::"('a, 'b, 'c, 'd) stateSP_scheme" and leq
   assume compare_spec:
       "\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j\<rbrace>"

  assume compare_modifies:
        "\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j)
                {t. t may_only_modify_globals \<tau> in []}"

   show "\<Gamma>\<turnstile>({s} \<inter> {\<sigma>})
            \<acute>b :== DYNCALL \<acute>compare (\<acute>n,\<acute>m);;
            IF \<acute>b THEN \<acute>k :== \<acute>n ELSE \<acute>k :== \<acute>m FI
            \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
     apply vcg
     apply (clarsimp simp add: mx_def)
     done
 qed

lemma (in Max_impl) Max_spec2:
shows
"\<forall>\<sigma> leq. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> \<lbrace>(\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
      (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply (clarsimp simp add: mx_def)
done

lemma (in Max_impl) Max_spec3:
shows
"\<forall>n m leq. \<Gamma>\<turnstile>
  (\<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace>  \<inter>
   \<lbrace>(\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
     (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq n m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply (clarsimp simp add: mx_def)
done

print_locale Max_spec

(* We have to rename the parameters of the compare procedure to match the LEQ procedure *)
locale Max_test = Max_spec where
        i_'compare_' = i_'LEQ_' and
        j_'compare_' = j_'LEQ_' and
        r_'compare_' = r_'LEQ_'
       + LEQ_spec + LEQ_modifies

lemma (in Max_test)
  shows
  "\<Gamma>\<turnstile> {\<sigma>} \<acute>k :== CALL Max(LEQ_'proc,\<acute>n,\<acute>m) \<lbrace>\<acute>k = mx (op \<le>) \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
proof -
  note Max_spec = Max_spec [where leq="(op \<le>)"]
  show ?thesis
    apply vcg
    apply (clarsimp)
    apply (rule conjI)
    apply (rule LEQ_spec)
    apply (rule LEQ_modifies)
    done
qed

lemma (in Max_impl) Max_spec5:
shows
"\<forall>n m leq. \<Gamma>\<turnstile>
  (\<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace> \<inter> \<lbrace>\<forall>n' m'. \<Gamma>\<turnstile> \<lbrace>\<acute>i=n' \<and> \<acute>j=m'\<rbrace> \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq n' m')\<rbrace>\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq n m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply clarsimp
apply (clarsimp simp add: mx_def)
done

lemma (in LEQ_impl)
 LEQ_spec: "\<forall>n m. \<Gamma>\<turnstile> \<lbrace>\<acute>i=n \<and> \<acute>j=m\<rbrace>  PROC LEQ(\<acute>i,\<acute>j,\<acute>r) \<lbrace>\<acute>r = (n \<le> m)\<rbrace>"
  apply vcg
  apply simp
  done

print_locale Max_impl
locale Max_test' = Max_impl where
        i_'compare_' = i_'LEQ_' and
        j_'compare_' = j_'LEQ_' and
        r_'compare_' = r_'LEQ_'
        + LEQ_impl
lemma (in Max_test')
  shows
  "\<forall>n m. \<Gamma>\<turnstile> \<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace> \<acute>k :== CALL Max(LEQ_'proc,\<acute>n,\<acute>m) \<lbrace>\<acute>k = mx (op \<le>) n m\<rbrace>"
proof -
  note Max_spec = Max_spec5
  show ?thesis
    apply vcg
    apply (rule_tac x="op \<le>" in exI)
    apply clarsimp
    apply (rule LEQ_spec [rule_format])
    done
qed

end


(*
 *
 * Copyright 2017, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(DATA61_GPL)
 *)

(*
   Test proofs for corres methods. Builds on AInvs image.
*)

theory Corres_Test
imports "Refine.VSpace_R" "Lib.Corres_Method"
begin

chapter \<open>The Corres Method\<close>

section \<open>Introduction\<close>

text \<open>The @{method corres} method tries to do for corres-style refinement proofs what
@{method wp} did for hoare logic proofs. The intention is to automate the application
of corres calculational rules, so that the bulk of the manual proof is now handling
a verification condition. In general refinement proofs are difficult to automate, so here we
exploit the fact that in l4v the abstract and executable specifications tend to be structurally
similar. Corres proofs are based on the @{const corres_underlying} constant, which takes a number
of parameters that allow it to be specialized for different flavours of refinement.

A corres statement has the following form: @{term "corres_underlying sr nf nf' r P P' f f'"}, where
@{term sr} is a state-relation, @{term nf} and @{term nf'} refer to whether or not the left and
right hand functions may fail, @{term r} is a return value relation between the functions, @{term P}
and @{term P'} are preconditions for the functions @{term f} and @{term f'} respectively. Informally
the statement says that: under the given preconditions, for every execution of @{term f'} there exists
an execution of @{term f} that is related by the given state relation @{term sr} and return-value
relation @{term r}.

If the left and right side of a corres statement share similar structure, we can "unzip" the function
into one corres obligation for each atomic function. This is done through the application of
  @{thm corres_split}.
\<close>

thm corres_split[no_vars]

text \<open>Briefly this states that: given a corres goal proving refinement between @{term "a >>= b"} and
  @{term "c >>= d"}, we can decompose this into a proof showing refinement between @{term a} and
@{term c}, and between @{term a} and @{term c}. Additionally @{term a} and @{term c} must establish
appropriate postconditions to satisfy the obligations of proving refinement between @{term b} and @{term d}.

The first subgoal that is produced has an important characteristic: the preconditions for each
side may only discuss the return value of its respective side. This means that rules such as
@{term "corres_underlying sr nf nf' r (\<lambda>s. x = x') (\<lambda>_. True) (f x) (f' x')"} will not apply to a goal
 if @{term x} and @{term x'} are variables generated by applying @{thm corres_split} (i.e. the
return values of functions).

This means that any such conditions must instead be phrased as an assumption to the rule, and our rule must be
rephrased as follows:
  @{term "x = x' \<Longrightarrow> corres_underlying sr nf nf' r (\<lambda>_. True) (\<lambda>_. True) (f x) (f' x')"}.
The result is that we must solve @{term "x = x'"} immediately after applying our rule. While this
is not a major concern for a manual proof, it proves to be a significant obstacle if we're trying
to focus on automating the "corres" part of the refinement.
\<close>

section \<open>corres_underlyingK and corres_rv\<close>

text \<open>To remedy this situation, we augment the @{const corres_underlying} definition to include
yet another flag: a single boolean. This new constant: @{const corres_underlyingK},
will form the basis of the calculus for our corres method.\<close>

thm corres_underlyingK_def[no_vars]

text \<open>The boolean in @{const corres_underlyingK} can be thought of as a stateless precondition. It
is used to propagate additional proof obligations for rules that either do not need to discuss
either the left or right hand state, or must discuss bound variables from both sides.\<close>

thm corresK_split[no_vars]

text \<open>In this split rule for @{const corres_underlyingK} we see that the additional precondition @{term F'}
may discuss both @{term rv} and @{term rv'}. To show that this condition is satisified, however,
we can't use hoare logic and instead need a new definition: @{const corres_rv}.\<close>

thm corres_rv_def_I_know_what_I'm_doing[no_vars]

text \<open>This is a weaker form of @{const corres_underlying} that is only interested in the return value
of the functions. In essence, it states the given functions will establish @{term Q} after executing,
assuming the given return-value relation @{term r} holds, along with the given stateless precondition
@{term F} and left/right preconditions @{term P} and @{term P'}.

The assumption in general is that corres_rv rules should never be written, instead corres_rv obligations
should be propagated into either the stateless precondition (@{term F} from @{term corres_underlyingK}),
the left precondition (@{term P}) or the right precondition @{term P'}. This is implicitly handled
by @{method corres_rv} (called from @{method corres}) by applying one of the following rules to each conjunct:\<close>

thm corres_rv_defer
thm corres_rv_wp_left
thm corres_rv_wp_right

text \<open>If none of these rules can be safely applied, then @{method corres_rv} will leave the
  obligation untouched. The user can manually apply one of them if desired, but this is liable to
  create unsolvable proof obligations. In the worst case, the user may manually solve the goal in-place.\<close>

thm corres_rv_proveT[no_vars]

section \<open>The corres method\<close>

text \<open>The core algorithm of the corres method is simple:
  1) start by applying any necessary weakening rules to ensure the goal has schematic preconditions
  2) apply a known @{thm corres} or @{thm corresK} rule (see next section)
  3) if unsuccessful, apply a split rule (i.e. @{thm corresK_split}) and go to 2

Importantly, @{method corres} will not split a goal if it ultimately is not able to apply at least
one @{thm corres} or @{thm corresK} rule.
\<close>

subsection \<open>The corres and corresK named_theorems\<close>

text \<open>To address the fact that existing refinement rules are phrased as @{const corres_underlying}
and not @{const corres_underlyingK} there are two different named_theorems that are used for different
kind of rules @{thm corres} and @{thm corresK}. A @{thm corres} rule is understood to be phrased
with @{const corres_underlying} and may have additional assumptions. These assumptions will be
propagated through the additional @{term F} flag in @{const corres_underlyingK}, rather than presented
as proof obligations immediately. A @{thm corresK} rule is understood to be phrased with
@{const corres_underlyingK}, and is meant for calculational rules which may have proper assumptions that
should not be propagated.
\<close>
thm corresK
thm corres

subsection \<open>The corresc method\<close>

text \<open>Similar to @{method wpc}, @{method corresc} can handle case statements in @{const corres_underlyingK}
proof goals. Importantly, however, it is split into two sub-methods @{method corresc_left} and
@{method corresc_right}, which perform case-splitting on each side respectively. The combined method
@{method corresc}, however, attempts to discharge the contradictions that arise from the quadratic
blowup of a case analysis on both the left and right sides.\<close>

subsection \<open>corres_concrete_r, corres_concrete_rE\<close>

text \<open>Some @{thm corresK} rules should only be applied if certain variables are concrete
(i.e. not schematic) in the goal. These are classified separately with the named_theorems
@{thm corres_concrete_r} and @{thm corres_concrete_rER}. The first
indicates that the return value relation of the goal must be concrete, the second indicates that
only the left side of the error relation must be concrete.\<close>

thm corres_concrete_r
thm corres_concrete_rER

subsection \<open>The corres_search method\<close>

text \<open>The purpose of @{method corres_search} is to address cases where there is non-trivial control flow.
In particular: in the case where there is an "if" statement or either side needs to be symbolically
executed. The core idea is that corres_search should be provided with a "search" rule that acts
as an anchoring point. Symbolic execution and control flow is decomposed until either the given
rule is successfully applied or all search branches are exhausted.\<close>

subsubsection \<open>Symbolic Execution\<close>

text \<open>Symbolic execution is handled by two named theorems:
 @{thm corres_symb_exec_ls} and @{thm corres_symb_exec_rs}, which perform symbolic execution on
the left and right hand sides of a corres goal.\<close>

thm corres_symb_exec_ls
thm corres_symb_exec_rs

text \<open>A function may be symbolically executed if it does not modify the state, i.e. its only purpose
is to compute some value and return it. After being symbolically executed,
this value can only be discussed by the precondition of the associated side or the stateless
precondition of corresK. The resulting @{const corres_rv} goal has @{const corres_noop} as the
function on the alternate side. This gives @{method corres_rv} a hint that the resulting obligation
should be aggressively re-written into a hoare triple over @{term m} if it can't be propagated
back statelessly safely.
\<close>

section \<open>Demo\<close>

context begin interpretation Arch .

(* VSpace_R *)

lemmas load_hw_asid_corres_args[corres] =
  load_hw_asid_corres[@lift_corres_args]

lemmas invalidate_asid_corres_args[corres] =
  invalidate_asid_corres[@lift_corres_args]

lemmas invalidate_hw_asid_entry_corres_args[corres] =
  invalidate_hw_asid_entry_corres[@lift_corres_args]

lemma invalidate_asid_entry_corres:
  "corres dc (valid_vspace_objs and valid_asid_map
                and K (asid \<le> mask asid_bits \<and> asid \<noteq> 0)
                and vspace_at_asid asid pd and valid_vs_lookup
                and unique_table_refs o caps_of_state
                and valid_global_objs and valid_arch_state
                and pspace_aligned and pspace_distinct)
             (pspace_aligned' and pspace_distinct' and no_0_obj')
             (invalidate_asid_entry asid) (invalidateASIDEntry asid)"
  apply (simp add: invalidate_asid_entry_def invalidateASIDEntry_def)
  apply_debug (trace) (* apply_trace between steps *)
   (tags "corres") (* break at breakpoints labelled "corres" *)
   corres (* weaken precondition *)
   continue (* split *)
   continue (* solve load_hw_asid *)
   continue (* split *)
   continue (* apply corres_when *)
   continue (* trivial simplification *)
   continue (* invalidate _hw_asid_entry *)
   finish (* invalidate_asid *)

  apply (corressimp wp: load_hw_asid_wp)+
  apply clarsimp
  apply (fastforce simp: pd_at_asid_uniq)
  done

crunch typ_at'[wp]: invalidateASIDEntry, flushSpace "typ_at' T t"
crunch ksCurThread[wp]: invalidateASIDEntry, flushSpace "\<lambda>s. P (ksCurThread s)"
crunch obj_at'[wp]: invalidateASIDEntry, flushSpace "obj_at' P p"

lemmas flush_space_corres_args[corres] =
  flush_space_corres[@lift_corres_args]

lemmas invalidate_asid_entry_corres_args[corres] =
  invalidate_asid_entry_corres[@lift_corres_args]

lemma corres_inst_eq_ext:
  "(\<And>x. corres_inst_eq (f x) (f' x)) \<Longrightarrow> corres_inst_eq f f'"
  by (auto simp add: corres_inst_eq_def)

lemma delete_asid_corresb:
  notes [corres] = corres_gets_asid gct_corres set_asid_pool_corres and
    [@lift_corres_args, corres] =  get_asid_pool_corres_inv'
    invalidate_asid_entry_corres
    set_vm_root_corres
  notes [wp] = set_asid_pool_asid_map_unmap set_asid_pool_vs_lookup_unmap'
    set_asid_pool_vspace_objs_unmap'
    invalidate_asid_entry_invalidates
    getASID_wp
  shows
    "corres dc
          (invs and valid_etcbs and K (asid \<le> mask asid_bits \<and> asid \<noteq> 0))
          (pspace_aligned' and pspace_distinct' and no_0_obj'
              and valid_arch_state' and cur_tcb')
          (delete_asid asid pd) (deleteASID asid pd)"
  apply (simp add: delete_asid_def deleteASID_def)
  apply_debug (trace) (* apply_trace between steps *)
    (tags "corres") (* break at breakpoints labelled "corres" *)
    corres (* weaken precondition *)
   continue (* split *)
       continue (* gets rule *)
      continue (* corresc *)
       continue (* return rule *)
      continue (* split *)
          continue (* function application *)
          continue (* liftM rule *)
          continue (* get_asid_pool_corres_inv' *)
         continue (* function application *)
         continue (* function application *)
         continue (* corresK_when *)
         continue (* split *)
             continue (* flush_space_corres *)
            continue (* K_bind *)
            continue (* K_bind *)
            continue (* split *)
                continue (* invalidate_asid_entry_corres *)
               continue (* K_bind *)
               continue (* return bind *)
               continue (* K_bind *)
               continue (* split *)
                   continue (* backtracking *)
               continue (* split *)
                   continue (* function application *)
                   continue (* set_asid_pool_corres *)
                  continue (* K_bind *)
                  continue (* K_bind *)
                  continue (* split *)
                      continue (* gct_corres *)
                     continue (* set_vm_root_corres *)
                    finish (* backtracking? *)
                    apply (corressimp simp: mask_asid_low_bits_ucast_ucast
      | fold cur_tcb_def | wps)+
  apply (frule arm_asid_table_related,clarsimp)
  apply (rule conjI)
   apply (intro impI allI)
    apply (rule conjI)
     apply (safe; assumption?)
     apply (rule ext)
     apply (fastforce simp: inv_def dest: ucast_ucast_eq)
    apply (rule context_conjI)
    apply (fastforce simp: o_def dest: valid_asid_tableD invs_valid_asid_table)
   apply (intro allI impI)
   apply (subgoal_tac "vspace_at_asid asid pd s")
    prefer 2
    apply (simp add: vspace_at_asid_def)
    apply (rule vs_lookupI)
     apply (simp add: vs_asid_refs_def)
     apply (rule image_eqI[OF refl])
     apply (rule graph_ofI)
     apply fastforce
    apply (rule r_into_rtrancl)
    apply simp
    apply (rule vs_lookup1I [OF _ _ refl], assumption)
    apply (simp add: vs_refs_def)
    apply (rule image_eqI[rotated], erule graph_ofI)
    apply (simp add: mask_asid_low_bits_ucast_ucast)
   prefer 2
   apply (intro allI impI context_conjI; assumption?)
    apply (rule aligned_distinct_relation_asid_pool_atI'; fastforce?)
    apply (fastforce simp: o_def dest: valid_asid_tableD invs_valid_asid_table)
    apply (simp add: cur_tcb'_def)
    apply (safe; assumption?)
    apply (erule ko_at_weakenE)
    apply (clarsimp simp: graph_of_def)
    apply (fastforce split: if_split_asm)
   apply (frule invs_vspace_objs)
   apply (drule (2) valid_vspace_objsD)
   apply (erule ranE)
   apply (fastforce split: if_split_asm)
  apply (erule ko_at_weakenE)
  apply (clarsimp simp: graph_of_def)
  apply (fastforce split: if_split_asm)
  done

lemma cte_wp_at_ex:
  "cte_wp_at (\<lambda>_. True) p s \<Longrightarrow> (\<exists>cap. cte_wp_at ((=) cap) p s)"
  by (simp add: cte_wp_at_def)

(* Sadly broken:
lemma set_vm_root_for_flush_corres:
  notes [corres] = gct_corres getSlotCap_corres
  shows
  "corres (=)
          (cur_tcb and vspace_at_asid asid pd
           and K (asid \<noteq> 0 \<and> asid \<le> mask asid_bits)
           and valid_asid_map and valid_vs_lookup
           and valid_vspace_objs and valid_global_objs
           and unique_table_refs o caps_of_state
           and valid_arch_state
           and pspace_aligned and pspace_distinct)
          (pspace_aligned' and pspace_distinct' and no_0_obj')
          (set_vm_root_for_flush pd asid)
          (setVMRootForFlush pd asid)"
  apply (simp add: set_vm_root_for_flush_def setVMRootForFlush_def getThreadVSpaceRoot_def locateSlot_conv)
  apply corres
         apply_debug (trace) (tags "corres_search") (corres_search search: arm_context_switch_corres)
  continue (* step left *)
  continue (* if rule *)
  continue (* failed corres on first subgoal, trying next *)
  continue (* fail corres on last subgoal, trying reverse if rule *)
  continue (* can't make corres progress here, trying other goal *)
  finish (* successful goal discharged by corres *)

  apply (corressimp wp: get_cap_wp getSlotCap_wp)+
  apply (rule context_conjI)
  subgoal by (simp add: cte_map_def objBits_simps tcb_cnode_index_def
                        tcbVTableSlot_def to_bl_1 cte_level_bits_def)
  apply (rule context_conjI)
  subgoal by (fastforce simp: cur_tcb_def intro!: tcb_at_cte_at_1[simplified])
  apply (rule conjI)
   subgoal by (fastforce simp: isCap_simps)
  apply (drule cte_wp_at_ex)
  apply clarsimp
  apply (drule (1) pspace_relation_cte_wp_at[rotated 1]; (assumption | clarsimp)?)
  apply (drule cte_wp_at_norm')
  apply clarsimp
  apply (rule_tac x="cteCap cte" in exI)
  apply (auto elim: cte_wp_at_weakenE' dest!: curthread_relation)
  done

text \<open>Note we can wrap it all up in corressimp\<close>

lemma set_vm_root_for_flush_corres':
  notes [corres] = gct_corres getSlotCap_corres
  shows
  "corres (=)
          (cur_tcb and vspace_at_asid asid pd
           and K (asid \<noteq> 0 \<and> asid \<le> mask asid_bits)
           and valid_asid_map and valid_vs_lookup
           and valid_vspace_objs and valid_global_objs
           and unique_table_refs o caps_of_state
           and valid_arch_state
           and pspace_aligned and pspace_distinct)
          (pspace_aligned' and pspace_distinct' and no_0_obj')
          (set_vm_root_for_flush pd asid)
          (setVMRootForFlush pd asid)"
  apply (simp add: set_vm_root_for_flush_def setVMRootForFlush_def getThreadVSpaceRoot_def locateSlot_conv)
  apply (corressimp search: arm_context_switch_corres
                        wp: get_cap_wp getSlotCap_wp
                      simp: isCap_simps)
  apply (rule context_conjI)
  subgoal by (simp add: cte_map_def objBits_simps tcb_cnode_index_def
                        tcbVTableSlot_def to_bl_1 cte_level_bits_def)
  apply (rule context_conjI)
  subgoal by (fastforce simp: cur_tcb_def intro!: tcb_at_cte_at_1[simplified])
  apply (rule conjI)
   subgoal by (fastforce)
  apply (drule cte_wp_at_ex)
  apply clarsimp
  apply (drule (1) pspace_relation_cte_wp_at[rotated 1]; (assumption | clarsimp)?)
  apply (drule cte_wp_at_norm')
  apply clarsimp
  apply (rule_tac x="cteCap cte" in exI)
  apply (auto elim: cte_wp_at_weakenE' dest!: curthread_relation)
  done
*)

end
end