section \<open> Reactive Healthiness Conditions \<close>

theory utp_rea_healths
  imports utp_rea_core
begin

subsection \<open> R1: Events cannot be undone \<close>

definition R1 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
R1_def [upred_defs]: "R1 (P) = (P \<and> ($tr \<le>\<^sub>u $tr\<acute>))"

utp_const R1

lemma R1_idem: "R1(R1(P)) = R1(P)"
  by pred_auto

lemma R1_Idempotent [closure]: "Idempotent R1"
  by (simp add: Idempotent_def R1_idem)

lemma R1_mono: "P \<sqsubseteq> Q \<Longrightarrow> R1(P) \<sqsubseteq> R1(Q)"
  by pred_auto

lemma R1_Monotonic: "Monotonic R1"
  by (simp add: mono_def R1_mono)

lemma R1_Continuous: "Continuous R1"
  by (auto simp add: Continuous_def, rel_auto)

lemma R1_unrest [unrest]: "\<lbrakk> x \<bowtie> in_var tr; x \<bowtie> out_var tr; x \<sharp> P \<rbrakk> \<Longrightarrow> x \<sharp> R1(P)"
  by (simp add: R1_def unrest lens_indep_sym)

lemma R1_false: "R1(false) = false"
  by pred_auto

lemma R1_conj: "R1(P \<and> Q) = (R1(P) \<and> R1(Q))"
  by pred_auto

lemma conj_R1_closed_1 [closure]: "P is R1 \<Longrightarrow> (P \<and> Q) is R1"
  by (rel_blast)

lemma conj_R1_closed_2 [closure]: "Q is R1 \<Longrightarrow> (P \<and> Q) is R1"
  by (rel_blast)

lemma R1_disj: "R1(P \<or> Q) = (R1(P) \<or> R1(Q))"
  by pred_auto

lemma disj_R1_closed [closure]: "\<lbrakk> P is R1; Q is R1 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R1"
  by (simp add: Healthy_def R1_def utp_pred_laws.inf_sup_distrib2)

lemma R1_impl: "R1(P \<Rightarrow> Q) = ((\<not> R1(\<not> P)) \<Rightarrow> R1(Q))"
  by (rel_auto)

lemma R1_inf: "R1(P \<sqinter> Q) = (R1(P) \<sqinter> R1(Q))"
  by pred_auto

lemma R1_USUP:
  "R1(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> R1(P(i)))"
  by (rel_auto)

lemma R1_Sup [closure]: "\<lbrakk> \<And> P. P \<in> A \<Longrightarrow> P is R1; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<Sqinter> A is R1"
  using R1_Continuous by (auto simp add: Continuous_def Healthy_def)

lemma R1_UINF:
  assumes "A \<noteq> {}"
  shows "R1(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> R1(P(i)))"
  using assms by (rel_auto)

lemma R1_UINF_ind:
  "R1(\<Squnion> i \<bullet> P(i)) = (\<Squnion> i \<bullet> R1(P(i)))"
  by (rel_auto)

lemma UINF_ind_R1_closed [closure]:
  "\<lbrakk> \<And> i. P(i) is R1 \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<bullet> P(i)) is R1"
  by (rel_blast)

lemma UINF_R1_closed [closure]:
  "\<lbrakk> \<And> i. P i is R1 \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<in> A \<bullet> P i) is R1"
  by (rel_blast)

lemma tr_ext_conj_R1 [closure]:
  "$tr\<acute> =\<^sub>u $tr ^\<^sub>u e \<and> P is R1"
  by (rel_auto, simp add: Prefix_Order.prefixI)

lemma tr_id_conj_R1 [closure]:
  "$tr\<acute> =\<^sub>u $tr \<and> P is R1"
  by (rel_auto)

lemma R1_extend_conj: "R1(P \<and> Q) = (R1(P) \<and> Q)"
  by pred_auto

lemma R1_extend_conj': "R1(P \<and> Q) = (P \<and> R1(Q))"
  by pred_auto

lemma R1_cond: "R1(P \<triangleleft> b \<triangleright> Q) = (R1(P) \<triangleleft> b \<triangleright> R1(Q))"
  by (rel_auto)

lemma R1_cond': "R1(P \<triangleleft> b \<triangleright> Q) = (R1(P) \<triangleleft> R1(b) \<triangleright> R1(Q))"
  by (rel_auto)

lemma R1_negate_R1: "R1(\<not> R1(P)) = R1(\<not> P)"
  by pred_auto

lemma R1_wait_true [usubst]: "(R1 P)\<^sub>t = R1(P)\<^sub>t"
  by pred_auto

lemma R1_wait_false [usubst]: "(R1 P) \<^sub>f = R1(P) \<^sub>f"
  by pred_auto

lemma R1_wait'_true [usubst]: "(R1 P)\<lbrakk>true/$wait\<acute>\<rbrakk> = R1(P\<lbrakk>true/$wait\<acute>\<rbrakk>)"
  by (rel_auto)

lemma R1_wait'_false [usubst]: "(R1 P)\<lbrakk>false/$wait\<acute>\<rbrakk> = R1(P\<lbrakk>false/$wait\<acute>\<rbrakk>)"
  by (rel_auto)

lemma R1_wait_false_closed [closure]: "P is R1 \<Longrightarrow> P\<lbrakk>false/$wait\<rbrakk> is R1"
  by (rel_auto)

lemma R1_wait'_false_closed [closure]: "P is R1 \<Longrightarrow> P\<lbrakk>false/$wait\<acute>\<rbrakk> is R1"
  by (rel_auto)

lemma R1_skip: "R1(II) = II"
  by (rel_auto)

lemma skip_is_R1 [closure]: "II is R1"
  by (rel_auto)

lemma subst_R1: "\<lbrakk> $tr \<sharp>\<^sub>s \<sigma>; $tr\<acute> \<sharp>\<^sub>s \<sigma>  \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (R1 P) = R1(\<sigma> \<dagger> P)"
  by (simp add: R1_def usubst usubst_apply_unrest)

lemma subst_R1_closed [closure]: "\<lbrakk> $tr \<sharp>\<^sub>s \<sigma>; $tr\<acute> \<sharp>\<^sub>s \<sigma>; P is R1 \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> P is R1"
  by (metis Healthy_def subst_R1)

lemma R1_by_refinement:
  "P is R1 \<longleftrightarrow> (($tr \<le>\<^sub>u $tr\<acute>) \<sqsubseteq> P)"
  by (rel_blast)

lemma R1_trace_extension [closure]:
  "$tr\<acute> \<ge>\<^sub>u $tr ^\<^sub>u e is R1"
  by (rel_auto)

lemma tr_le_trans:
  "(($tr \<le>\<^sub>u $tr\<acute>) ;; ($tr \<le>\<^sub>u $tr\<acute>)) = ($tr \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto)

lemma R1_seqr:
  "R1(R1(P) ;; R1(Q)) = (R1(P) ;; R1(Q))"
  by (rel_auto)

lemma R1_seqr_closure [closure]:
  assumes "P is R1" "Q is R1"
  shows "(P ;; Q) is R1"
  using assms unfolding R1_by_refinement
  by (metis seqr_mono tr_le_trans)

lemma R1_power [closure]: "P is R1 \<Longrightarrow> P\<^bold>^n is R1"
  by (induct n, simp_all add: upred_semiring.power_Suc closure)

lemma R1_true_comp [simp]: "(R1(true) ;; R1(true)) = R1(true)"
  by (rel_auto)

lemma R1_ok'_true: "(R1(P))\<^sup>t = R1(P\<^sup>t)"
  by pred_auto

lemma R1_ok'_false: "(R1(P))\<^sup>f = R1(P\<^sup>f)"
  by pred_auto

lemma R1_ok_true: "(R1(P))\<lbrakk>true/$ok\<rbrakk> = R1(P\<lbrakk>true/$ok\<rbrakk>)"
  by pred_auto

lemma R1_ok_false: "(R1(P))\<lbrakk>false/$ok\<rbrakk> = R1(P\<lbrakk>false/$ok\<rbrakk>)"
  by pred_auto

lemma seqr_R1_true_right: "((P ;; R1(true)) \<or> P) = (P ;; ($tr \<le>\<^sub>u $tr\<acute>))"
  by (rel_auto)

lemma conj_R1_true_right: "(P;;R1(true) \<and> Q;;R1(true)) ;; R1(true) = (P;;R1(true) \<and> Q;;R1(true))"
  apply (rel_auto) using dual_order.trans by blast+

lemma R1_extend_conj_unrest: "\<lbrakk> $tr \<sharp> Q; $tr\<acute> \<sharp> Q \<rbrakk> \<Longrightarrow> R1(P \<and> Q) = (R1(P) \<and> Q)"
  by pred_auto

lemma R1_extend_conj_unrest': "\<lbrakk> $tr \<sharp> P; $tr\<acute> \<sharp> P \<rbrakk> \<Longrightarrow> R1(P \<and> Q) = (P \<and> R1(Q))"
  by pred_auto

lemma R1_tr'_eq_tr: "R1($tr\<acute> =\<^sub>u $tr) = ($tr\<acute> =\<^sub>u $tr)"
  by (rel_auto)

lemma R1_tr_less_tr': "R1($tr <\<^sub>u $tr\<acute>) = ($tr <\<^sub>u $tr\<acute>)"
  by (rel_auto)

lemma tr_strict_prefix_R1_closed [closure]: "$tr <\<^sub>u $tr\<acute> is R1"
  by (rel_auto)

lemma R1_H2_commute: "R1(H2(P)) = H2(R1(P))"
  by (simp add: H2_split R1_def usubst, rel_auto)

subsection \<open> R2: No dependence upon trace history \<close>

text \<open> There are various ways of expressing $R2$, which are enumerated below. \<close>

definition R2a :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[upred_defs]: "R2a (P) = (\<Sqinter> s \<bullet> P\<lbrakk>\<guillemotleft>s\<guillemotright>,(\<guillemotleft>s\<guillemotright>+($tr\<acute>-$tr))/$tr,$tr\<acute>\<rbrakk>)"

definition R2a' :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[upred_defs]: "R2a' P = (R2a(P) \<triangleleft> R1(true) \<triangleright> P)"

definition R2s :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[upred_defs]: "R2s (P) = (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>($tr\<acute>-$tr)/$tr\<acute>\<rbrakk>)"

definition R2 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "R2(P) = R1(R2s(P))"

definition R2c :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "R2c(P) = (R2s(P) \<triangleleft> R1(true) \<triangleright> P)"

text \<open> @{term R2a} and @{term R2s} are the standard definitions from the UTP book~\cite{Hoare&98}.
  An issue with these forms is that their definition depends upon @{term R1} also being
  satisfied~\cite{Foster17b}, since otherwise the trace minus operator is not well defined.
  We overcome this with our own version, @{term R2c}, which applies @{term R2s} if @{term R1} holds,
  and otherwise has no effect. This latter healthiness condition can therefore be reasoned about
  independently of @{term R1}, which is useful in some circumstances. \<close>

lemma unrest_ok_R2s [unrest]: "$ok \<sharp> P \<Longrightarrow> $ok \<sharp> R2s(P)"
  by (simp add: R2s_def unrest)

lemma unrest_ok'_R2s [unrest]: "$ok\<acute> \<sharp> P \<Longrightarrow> $ok\<acute> \<sharp> R2s(P)"
  by (simp add: R2s_def unrest)

lemma unrest_ok_R2c [unrest]: "$ok \<sharp> P \<Longrightarrow> $ok \<sharp> R2c(P)"
  by (simp add: R2c_def unrest)

lemma unrest_ok'_R2c [unrest]: "$ok\<acute> \<sharp> P \<Longrightarrow> $ok\<acute> \<sharp> R2c(P)"
  by (simp add: R2c_def unrest)

lemma R2s_unrest [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> in_var tr; x \<bowtie> out_var tr; x \<sharp> P \<rbrakk> \<Longrightarrow> x \<sharp> R2s(P)"
  by (simp add: R2s_def unrest usubst lens_indep_sym)

lemma R2s_subst_wait_true [usubst]:
  "(R2s(P))\<lbrakk>true/$wait\<rbrakk> = R2s(P\<lbrakk>true/$wait\<rbrakk>)"
  by (simp add: R2s_def usubst unrest)

lemma R2s_subst_wait'_true [usubst]:
  "(R2s(P))\<lbrakk>true/$wait\<acute>\<rbrakk> = R2s(P\<lbrakk>true/$wait\<acute>\<rbrakk>)"
  by (simp add: R2s_def usubst unrest)

lemma R2_subst_wait_true [usubst]:
  "(R2(P))\<lbrakk>true/$wait\<rbrakk> = R2(P\<lbrakk>true/$wait\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)

lemma R2_subst_wait'_true [usubst]:
  "(R2(P))\<lbrakk>true/$wait\<acute>\<rbrakk> = R2(P\<lbrakk>true/$wait\<acute>\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)

lemma R2_subst_wait_false [usubst]:
  "(R2(P))\<lbrakk>false/$wait\<rbrakk> = R2(P\<lbrakk>false/$wait\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)

lemma R2_subst_wait'_false [usubst]:
  "(R2(P))\<lbrakk>false/$wait\<acute>\<rbrakk> = R2(P\<lbrakk>false/$wait\<acute>\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)

lemma R2c_R2s_absorb: "R2c(R2s(P)) = R2s(P)"
  by (rel_auto)

lemma R2a_R2s: "R2a(R2s(P)) = R2s(P)"
  by (rel_auto)

lemma R2s_R2a: "R2s(R2a(P)) = R2a(P)"
  by (rel_auto)

lemma R2a_equiv_R2s: "P is R2a \<longleftrightarrow> P is R2s"
  by (metis Healthy_def' R2a_R2s R2s_R2a)

lemma R2a_idem: "R2a(R2a(P)) = R2a(P)"
  by (rel_auto)

lemma R2a'_idem: "R2a'(R2a'(P)) = R2a'(P)"
  by (rel_auto)

lemma R2a_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2a(P) \<sqsubseteq> R2a(Q)"
  by (rel_blast)

lemma R2a'_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2a'(P) \<sqsubseteq> R2a'(Q)"
  by (rel_blast)

lemma R2a'_weakening: "R2a'(P) \<sqsubseteq> P"
  apply (rel_simp)
  apply (rename_tac ok wait tr more ok' wait' tr' more')
  apply (rule_tac x="tr" in exI)
  apply (simp add: diff_add_cancel_left')
  done

lemma R2s_idem: "R2s(R2s(P)) = R2s(P)"
  by (pred_auto)

lemma R2_idem: "R2(R2(P)) = R2(P)"
  by (pred_auto)

lemma R2_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2(P) \<sqsubseteq> R2(Q)"
  by (pred_auto)

lemma R2_implies_R1 [closure]: "P is R2 \<Longrightarrow> P is R1"
  by (rel_blast)

lemma R2_implies_R2c [closure]: "P is R2 \<Longrightarrow> P is R2c"
  by (rel_blast)

lemma R2c_Continuous: "Continuous R2c"
  by (rel_simp)

lemma R2c_lit: "R2c(\<guillemotleft>x\<guillemotright>) = \<guillemotleft>x\<guillemotright>"
  by (rel_auto)

lemma tr_strict_prefix_R2c_closed [closure]: "$tr <\<^sub>u $tr\<acute> is R2c"
  by (rel_auto)

lemma R2s_conj: "R2s(P \<and> Q) = (R2s(P) \<and> R2s(Q))"
  by (pred_auto)

lemma R2_conj: "R2(P \<and> Q) = (R2(P) \<and> R2(Q))"
  by (pred_auto)

lemma R2s_disj: "R2s(P \<or> Q) = (R2s(P) \<or> R2s(Q))"
  by pred_auto

lemma R2s_USUP:
  "R2s(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> R2s(P(i)))"
  by (simp add: R2s_def usubst)

lemma R2c_USUP:
  "R2c(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> R2c(P(i)))"
  by (rel_auto)

lemma R2s_UINF:
  "R2s(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> R2s(P(i)))"
  by (simp add: R2s_def usubst)

lemma R2c_UINF:
  "R2c(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> R2c(P(i)))"
  by (rel_auto)

lemma R2_disj: "R2(P \<or> Q) = (R2(P) \<or> R2(Q))"
  by (pred_auto)

lemma R2s_not: "R2s(\<not> P) = (\<not> R2s(P))"
  by pred_auto

lemma R2s_condr: "R2s(P \<triangleleft> b \<triangleright> Q) = (R2s(P) \<triangleleft> R2s(b) \<triangleright> R2s(Q))"
  by (rel_auto)

lemma R2_condr: "R2(P \<triangleleft> b \<triangleright> Q) = (R2(P) \<triangleleft> R2(b) \<triangleright> R2(Q))"
  by (rel_auto)

lemma R2_condr': "R2(P \<triangleleft> b \<triangleright> Q) = (R2(P) \<triangleleft> R2s(b) \<triangleright> R2(Q))"
  by (rel_auto)

lemma R2s_ok: "R2s($ok) = $ok"
  by (rel_auto)

lemma R2s_ok': "R2s($ok\<acute>) = $ok\<acute>"
  by (rel_auto)

lemma R2s_wait: "R2s($wait) = $wait"
  by (rel_auto)

lemma R2s_wait': "R2s($wait\<acute>) = $wait\<acute>"
  by (rel_auto)

lemma R2s_true: "R2s(true) = true"
  by pred_auto

lemma R2s_false: "R2s(false) = false"
  by pred_auto

lemma true_is_R2s:
  "true is R2s"
  by (simp add: Healthy_def R2s_true)

lemma R2s_lift_rea: "R2s(\<lceil>P\<rceil>\<^sub>R) = \<lceil>P\<rceil>\<^sub>R"
  by (simp add: R2s_def usubst unrest)

lemma R2c_lift_rea: "R2c(\<lceil>P\<rceil>\<^sub>R) = \<lceil>P\<rceil>\<^sub>R"
  by (simp add: R2c_def R2s_lift_rea cond_idem usubst unrest)

lemma R2c_true: "R2c(true) = true"
  by (rel_auto)

lemma R2c_false: "R2c(false) = false"
  by (rel_auto)

lemma R2c_and: "R2c(P \<and> Q) = (R2c(P) \<and> R2c(Q))"
  by (rel_auto)

lemma conj_R2c_closed [closure]: "\<lbrakk> P is R2c; Q is R2c \<rbrakk> \<Longrightarrow> (P \<and> Q) is R2c"
  by (simp add: Healthy_def R2c_and)

lemma R2c_disj: "R2c(P \<or> Q) = (R2c(P) \<or> R2c(Q))"
  by (rel_auto)

lemma R2c_inf: "R2c(P \<sqinter> Q) = (R2c(P) \<sqinter> R2c(Q))"
  by (rel_auto)

lemma R2c_not: "R2c(\<not> P) = (\<not> R2c(P))"
  by (rel_auto)

lemma R2c_ok: "R2c($ok) = ($ok)"
  by (rel_auto)

lemma R2c_ok': "R2c($ok\<acute>) = ($ok\<acute>)"
  by (rel_auto)

lemma R2c_wait: "R2c($wait) = $wait"
  by (rel_auto)

lemma R2c_wait': "R2c($wait\<acute>) = $wait\<acute>"
  by (rel_auto)

lemma R2c_wait'_true [usubst]: "(R2c P)\<lbrakk>true/$wait\<acute>\<rbrakk> = R2c(P\<lbrakk>true/$wait\<acute>\<rbrakk>)"
  by (rel_auto)

lemma R2c_wait'_false [usubst]: "(R2c P)\<lbrakk>false/$wait\<acute>\<rbrakk> = R2c(P\<lbrakk>false/$wait\<acute>\<rbrakk>)"
  by (rel_auto)

lemma R2c_tr'_minus_tr: "R2c($tr\<acute> =\<^sub>u $tr) = ($tr\<acute> =\<^sub>u $tr)"
  apply (rel_auto) using minus_zero_eq by blast

lemma R2c_tr_le_tr': "R2c($tr \<le>\<^sub>u $tr\<acute>) = ($tr \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto)

lemma R2c_tr'_ge_tr: "R2c($tr\<acute> \<ge>\<^sub>u $tr) = ($tr\<acute> \<ge>\<^sub>u $tr)"
  by (rel_auto)

lemma R2c_tr_less_tr': "R2c($tr <\<^sub>u $tr\<acute>) = ($tr <\<^sub>u $tr\<acute>)"
  by (rel_auto)

lemma R2c_condr: "R2c(P \<triangleleft> b \<triangleright> Q) = (R2c(P) \<triangleleft> R2c(b) \<triangleright> R2c(Q))"
  by (rel_auto)

lemma R2c_shAll: "R2c (\<^bold>\<forall> x \<bullet> P x) = (\<^bold>\<forall> x \<bullet> R2c(P x))"
  by (rel_auto)

lemma R2c_impl: "R2c(P \<Rightarrow> Q) = (R2c(P) \<Rightarrow> R2c(Q))"
  by (metis (no_types, lifting) R2c_and R2c_not double_negation impl_alt_def not_conj_deMorgans)

lemma R2c_skip_r: "R2c(II) = II"
proof -
  have "R2c(II) = R2c($tr\<acute> =\<^sub>u $tr \<and> II\<restriction>\<^sub>\<alpha>tr)"
    by (subst skip_r_unfold[of tr], simp_all)
  also have "... = (R2c($tr\<acute> =\<^sub>u $tr) \<and> II\<restriction>\<^sub>\<alpha>tr)"
    by (simp add: R2c_and, simp add: R2c_def R2s_def usubst unrest cond_idem)
  also have "... = ($tr\<acute> =\<^sub>u $tr \<and> II\<restriction>\<^sub>\<alpha>tr)"
    by (simp add: R2c_tr'_minus_tr)
  finally show ?thesis
    by (subst skip_r_unfold[of tr], simp_all)
qed

lemma R1_R2c_commute: "R1(R2c(P)) = R2c(R1(P))"
  by (rel_auto)

lemma R1_R2c_is_R2: "R1(R2c(P)) = R2(P)"
  by (rel_auto)

lemma R1_R2s_R2c: "R1(R2s(P)) = R1(R2c(P))"
  by (rel_auto)

lemma R1_R2s_tr_wait:
  "R1 (R2s ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)) = ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)"
  apply rel_auto using minus_zero_eq by blast

lemma R1_R2s_tr'_eq_tr:
  "R1 (R2s ($tr\<acute> =\<^sub>u $tr)) = ($tr\<acute> =\<^sub>u $tr)"
  apply (rel_auto) using minus_zero_eq by blast

lemma R1_R2s_tr'_extend_tr:
  "\<lbrakk> $tr \<sharp> v; $tr\<acute> \<sharp> v \<rbrakk> \<Longrightarrow> R1 (R2s ($tr\<acute> =\<^sub>u $tr ^\<^sub>u v)) = ($tr\<acute> =\<^sub>u $tr  ^\<^sub>u v)"
  apply (rel_auto)
   apply (metis append_minus)
  apply (simp add: Prefix_Order.prefixI)
  done

lemma R2_tr_prefix: "R2($tr \<le>\<^sub>u $tr\<acute>) = ($tr \<le>\<^sub>u $tr\<acute>)"
  by (pred_auto)

lemma R2_form:
  "R2(P) = (\<^bold>\<exists> tt\<^sub>0 \<bullet> P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright>)"
  by (rel_auto, metis trace_class.add_diff_cancel_left trace_class.le_iff_add)

lemma R2_subst_tr:
  assumes "P is R2"
  shows "[$tr \<mapsto>\<^sub>s tr\<^sub>0, $tr\<acute> \<mapsto>\<^sub>s tr\<^sub>0 + t] \<dagger> P = [$tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s t] \<dagger> P"
proof -
  have "[$tr \<mapsto>\<^sub>s tr\<^sub>0, $tr\<acute> \<mapsto>\<^sub>s tr\<^sub>0 + t] \<dagger> R2 P = [$tr \<mapsto>\<^sub>s 0, $tr\<acute> \<mapsto>\<^sub>s t] \<dagger> R2 P"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R2_seqr_form:
  shows "(R2(P) ;; R2(Q)) =
         (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>))
                        \<and> ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
proof -
  have "(R2(P) ;; R2(Q)) = (\<^bold>\<exists> tr\<^sub>0 \<bullet> (R2(P))\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; (R2(Q))\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>)"
    by (subst seqr_middle[of tr], simp_all)
  also have "... =
       (\<^bold>\<exists> tr\<^sub>0 \<bullet> \<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> \<and> \<guillemotleft>tr\<^sub>0\<guillemotright> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright>) ;;
                                (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk> \<and> $tr\<acute> =\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)))"
    by (simp add: R2_form usubst unrest uquant_lift, rel_blast)
  also have "... =
       (\<^bold>\<exists> tr\<^sub>0 \<bullet> \<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((\<guillemotleft>tr\<^sub>0\<guillemotright> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> \<and> P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;;
                                (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk> \<and> $tr\<acute> =\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)))"
    by (simp add: conj_comm)
  also have "... =
       (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> \<^bold>\<exists> tr\<^sub>0 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>))
                                \<and> \<guillemotleft>tr\<^sub>0\<guillemotright> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> \<and> $tr\<acute> =\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
    by (rel_blast)
  also have "... =
       (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>))
                        \<and> (\<^bold>\<exists> tr\<^sub>0 \<bullet> \<guillemotleft>tr\<^sub>0\<guillemotright> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> \<and> $tr\<acute> =\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
    by (rel_auto)
  also have "... =
       (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>))
                        \<and> ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma R2_seqr_form':
  assumes "P is R2" "Q is R2"
  shows "P ;; Q =
         (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>))
                        \<and> ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
  using R2_seqr_form[of P Q] by (simp add: Healthy_if assms)

lemma R2_seqr_form'':
  assumes "P is R2" "Q is R2"
  shows "P ;; Q =
         (\<^bold>\<exists> (tt\<^sub>1, tt\<^sub>2) \<bullet> ((P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr,$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr,$tr\<acute>\<rbrakk>))
                         \<and> ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
  by (subst R2_seqr_form', simp_all add: assms, rel_auto)

lemma R2_tr_middle:
  assumes "P is R2" "Q is R2"
  shows "(\<^bold>\<exists> tr\<^sub>0 \<bullet> (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>) \<and> \<guillemotleft>tr\<^sub>0\<guillemotright> \<le>\<^sub>u $tr\<acute>) = (P ;; Q)"
proof -
  have "(P ;; Q) = (\<^bold>\<exists> tr\<^sub>0 \<bullet> (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>))"
    by (simp add: seqr_middle)
  also have "... = (\<^bold>\<exists> tr\<^sub>0 \<bullet> ((R2 P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; (R2 Q)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>))"
    by (simp add: assms Healthy_if)
  also have "... = (\<^bold>\<exists> tr\<^sub>0 \<bullet> ((R2 P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; (R2 Q)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>) \<and> \<guillemotleft>tr\<^sub>0\<guillemotright> \<le>\<^sub>u $tr\<acute>)"
    by (rel_auto)
  also have "... = (\<^bold>\<exists> tr\<^sub>0 \<bullet> (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<rbrakk>) \<and> \<guillemotleft>tr\<^sub>0\<guillemotright> \<le>\<^sub>u $tr\<acute>)"
    by (simp add: assms Healthy_if)
  finally show ?thesis ..
qed

lemma R2_seqr_distribute:
  fixes P :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" and Q :: "('t,'\<beta>,'\<gamma>) rel_rp"
  shows "R2(R2(P) ;; R2(Q)) = (R2(P) ;; R2(Q))"
proof -
  have "R2(R2(P) ;; R2(Q)) =
    ((\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>)\<lbrakk>($tr\<acute> - $tr)/$tr\<acute>\<rbrakk>
      \<and> $tr\<acute> - $tr =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) \<and> $tr\<acute> \<ge>\<^sub>u $tr)"
    by (simp add: R2_seqr_form, simp add: R2s_def usubst unrest, rel_auto)
  also have "... =
    ((\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>)\<lbrakk>(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)/$tr\<acute>\<rbrakk>
      \<and> $tr\<acute> - $tr =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) \<and> $tr\<acute> \<ge>\<^sub>u $tr)"
      by (subst subst_eq_replace, simp)
  also have "... =
    ((\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>)
      \<and> $tr\<acute> - $tr =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) \<and> $tr\<acute> \<ge>\<^sub>u $tr)"
      by (rel_auto)
  also have "... =
    (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>)
      \<and> ($tr\<acute> - $tr =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright> \<and> $tr\<acute> \<ge>\<^sub>u $tr))"
    by pred_auto
  also have "... =
    ((\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (P\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr\<acute>\<rbrakk> ;; Q\<lbrakk>0/$tr\<rbrakk>\<lbrakk>\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr\<acute>\<rbrakk>)
      \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
  proof -
    have "\<And> tt\<^sub>1 tt\<^sub>2. ((($tr\<acute> - $tr =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) \<and> $tr\<acute> \<ge>\<^sub>u $tr) :: ('t,'\<alpha>,'\<gamma>) rel_rp)
           = ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      apply (rel_auto)
        apply (metis add.assoc diff_add_cancel_left')
       apply (simp add: add.assoc)
      apply (meson le_add order_trans)
      done
    thus ?thesis by simp
  qed
  also have "... = (R2(P) ;; R2(Q))"
    by (simp add: R2_seqr_form)
  finally show ?thesis .
qed

lemma R2_seqr_closure [closure]:
  assumes "P is R2" "Q is R2"
  shows "(P ;; Q) is R2"
  by (metis Healthy_def' R2_seqr_distribute assms(1) assms(2))

lemma false_R2 [closure]: "false is R2"
  by (rel_auto)

lemma R1_R2_commute:
  "R1(R2(P)) = R2(R1(P))"
  by pred_auto

lemma R2_R1_form: "R2(R1(P)) = R1(R2s(P))"
  by (rel_auto)

lemma R2s_H1_commute:
  "R2s(H1(P)) = H1(R2s(P))"
  by (rel_auto)

lemma R2s_H2_commute:
  "R2s(H2(P)) = H2(R2s(P))"
  by (simp add: H2_split R2s_def usubst)

lemma R2_R1_seq_drop_left:
  "R2(R1(P) ;; R1(Q)) = R2(P ;; R1(Q))"
  by (rel_auto)

lemma R2c_idem: "R2c(R2c(P)) = R2c(P)"
  by (rel_auto)

lemma R2c_Idempotent [closure]: "Idempotent R2c"
  by (simp add: Idempotent_def R2c_idem)

lemma R2c_Monotonic [closure]: "Monotonic R2c"
  by (rel_auto)

lemma R2c_H2_commute: "R2c(H2(P)) = H2(R2c(P))"
  by (simp add: H2_split R2c_disj R2c_def R2s_def usubst, rel_auto)

lemma R2c_seq: "R2c(R2(P) ;; R2(Q)) = (R2(P) ;; R2(Q))"
  by (metis (no_types, lifting) R1_R2c_commute R1_R2c_is_R2 R2_seqr_distribute R2c_idem)

lemma R2_R2c_def: "R2(P) = R1(R2c(P))"
  by (rel_auto)

lemma R2_comp_def: "R2 = R1 \<circ> R2c"
  by (auto simp add: R2_R2c_def)

lemma R2c_R1_seq: "R2c(R1(R2c(P)) ;; R1(R2c(Q))) = (R1(R2c(P)) ;; R1(R2c(Q)))"
  using R2c_seq[of P Q] by (simp add: R2_R2c_def)

lemma R1_R2c_seqr_distribute:
  fixes P :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" and Q :: "('t,'\<beta>,'\<gamma>) rel_rp"
  assumes "P is R1" "P is R2c" "Q is R1" "Q is R2c"
  shows "R1(R2c(P ;; Q)) = P ;; Q"
  by (metis Healthy_if R1_seqr R2c_R1_seq assms)

lemma R2_R1_true:
  "R2(R1(true)) = R1(true)"
  by (simp add: R2_R1_form R2s_true)

lemma R1_true_R2 [closure]: "R1(true) is R2"
  by (rel_auto)

lemma R1_R2s_R1_true_lemma:
  "R1(R2s(R1 (\<not> R2s P) ;; R1 true)) = R1(R2s((\<not> P) ;; R1 true))"
  by (rel_auto)

lemma R2c_healthy_R2s: "P is R2c \<Longrightarrow> R1(R2s(P)) = R1(P)"
  by (simp add: Healthy_def R1_R2s_R2c)

subsection \<open> R3: No activity while predecessor is waiting \<close>

definition R3 :: "('t::trace, '\<alpha>) hrel_rp \<Rightarrow> ('t, '\<alpha>) hrel_rp" where
[upred_defs]: "R3(P) = (II \<triangleleft> $wait \<triangleright> P)"

lemma R3_idem: "R3(R3(P)) = R3(P)"
  by (rel_auto)

lemma R3_Idempotent [closure]: "Idempotent R3"
  by (simp add: Idempotent_def R3_idem)

lemma R3_mono: "P \<sqsubseteq> Q \<Longrightarrow> R3(P) \<sqsubseteq> R3(Q)"
  by (rel_auto)

lemma R3_Monotonic: "Monotonic R3"
  by (simp add: mono_def R3_mono)

lemma R3_Continuous: "Continuous R3"
  by (rel_auto)

lemma R3_conj: "R3(P \<and> Q) = (R3(P) \<and> R3(Q))"
  by (rel_auto)

lemma R3_disj: "R3(P \<or> Q) = (R3(P) \<or> R3(Q))"
  by (rel_auto)

lemma R3_USUP:
  assumes "A \<noteq> {}"
  shows "R3(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> R3(P(i)))"
  using assms by (rel_auto)

lemma R3_UINF:
  assumes "A \<noteq> {}"
  shows "R3(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> R3(P(i)))"
  using assms by (rel_auto)

lemma R3_condr: "R3(P \<triangleleft> b \<triangleright> Q) = (R3(P) \<triangleleft> b \<triangleright> R3(Q))"
  by (rel_auto)

lemma R3_skipr: "R3(II) = II"
  by (rel_auto)

lemma R3_form: "R3(P) = (($wait \<and> II) \<or> (\<not> $wait \<and> P))"
  by (rel_auto)

lemma wait_R3:
  "($wait \<and> R3(P)) = (II \<and> $wait\<acute>)"
  by (rel_auto)

lemma nwait_R3:
  "(\<not>$wait \<and> R3(P)) = (\<not>$wait \<and> P)"
  by (rel_auto)

lemma R3_semir_form:
  "(R3(P) ;; R3(Q)) = R3(P ;; R3(Q))"
  by (rel_auto)

lemma R3_semir_closure:
  assumes "P is R3" "Q is R3"
  shows "(P ;; Q) is R3"
  using assms
  by (metis Healthy_def' R3_semir_form)

lemma R1_R3_commute: "R1(R3(P)) = R3(R1(P))"
  by (rel_auto)

lemma R2_R3_commute: "R2(R3(P)) = R3(R2(P))"
  apply (rel_auto)
  using minus_zero_eq apply blast+
  done

subsection \<open> R4: The trace strictly increases \<close>

definition R4 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "R4(P) = (P \<and> $tr <\<^sub>u $tr\<acute>)"

lemma R4_implies_R1 [closure]: "P is R4 \<Longrightarrow> P is R1"
  using less_iff by rel_blast

lemma R4_iff_refine:
  "P is R4 \<longleftrightarrow> ($tr <\<^sub>u $tr\<acute>) \<sqsubseteq> P"
  by (rel_blast)

lemma R4_idem: "R4 (R4 P) = R4 P"
  by (rel_auto)

lemma R4_false: "R4(false) = false"
  by (rel_auto)

lemma R4_conj: "R4(P \<and> Q) = (R4(P) \<and> R4(Q))"
  by (rel_auto)

lemma R4_disj: "R4(P \<or> Q) = (R4(P) \<or> R4(Q))"
  by (rel_auto)

lemma R4_is_R4 [closure]: "R4(P) is R4"
  by (rel_auto)

lemma false_R4 [closure]: "false is R4"
  by (rel_auto)

lemma UINF_R4_closed [closure]:
  "\<lbrakk> \<And> i. P i is R4 \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<bullet> P i) is R4"
  by (rel_blast)

lemma conj_R4_closed [closure]:
  "\<lbrakk> P is R4; Q is R4 \<rbrakk> \<Longrightarrow> (P \<and> Q) is R4"
  by (simp add: Healthy_def R4_conj)

lemma disj_R4_closed [closure]:
  "\<lbrakk> P is R4; Q is R4 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R4"
  by (simp add: Healthy_def R4_disj)

lemma seq_R4_closed_1 [closure]:
  "\<lbrakk> P is R4; Q is R1 \<rbrakk> \<Longrightarrow> (P ;; Q) is R4"
  using less_le_trans by rel_blast

lemma seq_R4_closed_2 [closure]:
  "\<lbrakk> P is R1; Q is R4 \<rbrakk> \<Longrightarrow> (P ;; Q) is R4"
  using le_less_trans by rel_blast

subsection \<open> R5: The trace does not increase \<close>

definition R5 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "R5(P) = (P \<and> $tr =\<^sub>u $tr\<acute>)"

lemma R5_implies_R1 [closure]: "P is R5 \<Longrightarrow> P is R1"
  using eq_iff by rel_blast

lemma R5_iff_refine:
  "P is R5 \<longleftrightarrow> ($tr =\<^sub>u $tr\<acute>) \<sqsubseteq> P"
  by (rel_blast)

lemma R5_conj: "R5(P \<and> Q) = (R5(P) \<and> R5(Q))"
  by (rel_auto)

lemma R5_disj: "R5(P \<or> Q) = (R5(P) \<or> R5(Q))"
  by (rel_auto)

lemma R4_R5: "R4 (R5 P) = false"
  by (rel_auto)

lemma R5_R4: "R5 (R4 P) = false"
  by (rel_auto)

lemma UINF_R5_closed [closure]:
  "\<lbrakk> \<And> i. P i is R5 \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<bullet> P i) is R5"
  by (rel_blast)

lemma conj_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P \<and> Q) is R5"
  by (simp add: Healthy_def R5_conj)

lemma disj_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R5"
  by (simp add: Healthy_def R5_disj)

lemma seq_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P ;; Q) is R5"
  by (rel_auto, metis)

subsection {* RP laws *}

definition RP_def [upred_defs]: "RP(P) = R1(R2c(R3(P)))"

lemma RP_comp_def: "RP = R1 \<circ> R2c \<circ> R3"
  by (auto simp add: RP_def)

lemma RP_alt_def: "RP(P) = R1(R2(R3(P)))"
  by (metis R1_R2c_is_R2 R1_idem RP_def)

lemma RP_intro: "\<lbrakk> P is R1; P is R2; P is R3 \<rbrakk> \<Longrightarrow> P is RP"
  by (simp add: Healthy_def' RP_alt_def)

lemma RP_idem: "RP(RP(P)) = RP(P)"
  by (simp add: R1_R2c_is_R2 R2_R3_commute R2_idem R3_idem RP_def)

lemma RP_Idempotent [closure]: "Idempotent RP"
  by (simp add: Idempotent_def RP_idem)

lemma RP_mono: "P \<sqsubseteq> Q \<Longrightarrow> RP(P) \<sqsubseteq> RP(Q)"
  by (simp add: R1_R2c_is_R2 R2_mono R3_mono RP_def)

lemma RP_Monotonic: "Monotonic RP"
  by (simp add: mono_def RP_mono)

lemma RP_Continuous: "Continuous RP"
  by (simp add: Continuous_comp R1_Continuous R2c_Continuous R3_Continuous RP_comp_def)

lemma RP_skip:
  "RP(II) = II"
  by (simp add: R1_skip R2c_skip_r R3_skipr RP_def)

lemma RP_skip_closure [closure]:
  "II is RP"
  by (simp add: Healthy_def' RP_skip)

lemma RP_seq_closure [closure]:
  assumes "P is RP" "Q is RP"
  shows "(P ;; Q) is RP"
proof (rule RP_intro)
  show "(P ;; Q) is R1"
    by (metis Healthy_def R1_seqr RP_def assms)
  thus "(P ;; Q) is R2"
    by (metis Healthy_def' R2_R2c_def R2c_R1_seq RP_def  assms)
  show "(P ;; Q) is R3"
    by (metis (no_types, lifting) Healthy_def' R1_R2c_is_R2 R2_R3_commute R3_idem R3_semir_form RP_def assms)
qed

subsection \<open> UTP theories \<close>

interpretation rea_theory: utp_theory_continuous RP
  rewrites "P \<in> carrier rea_theory.thy_order \<longleftrightarrow> P is RP"
  and "le des_theory.thy_order = (\<sqsubseteq>)"
  and "eq des_theory.thy_order = (=)"
proof -
  show "utp_theory_continuous RP"
    by (unfold_locales, simp_all add: RP_idem RP_Continuous)
qed (simp_all)

notation rea_theory.utp_top ("\<^bold>\<top>\<^sub>r")
notation rea_theory.utp_bottom ("\<^bold>\<bottom>\<^sub>r")

interpretation rea_theory_rel: utp_theory_unital RP skip_r
  by (unfold_locales, simp_all add: closure)

lemma rea_top: "\<^bold>\<top>\<^sub>r = ($wait \<and> II)"
proof -
  have "\<^bold>\<top>\<^sub>r = RP(false)"
    by (simp add: rea_theory.healthy_top)
  also have "... = ($wait \<and> II)"
    by (rel_auto, metis minus_zero_eq)
  finally show ?thesis .
qed

lemma rea_top_left_zero:
  assumes "P is RP"
  shows "(\<^bold>\<top>\<^sub>r ;; P) = \<^bold>\<top>\<^sub>r"
proof -
  have "(\<^bold>\<top>\<^sub>r ;; P) = (($wait \<and> II) ;; R3(P))"
    by (metis (no_types, lifting) Healthy_def R1_R2c_is_R2 R2_R3_commute R3_idem RP_def assms rea_top)
  also have "... = ($wait \<and> R3(P))"
    by (rel_auto)
  also have "... = ($wait \<and> II)"
    by (metis R3_skipr wait_R3)
  also have "... = \<^bold>\<top>\<^sub>r"
    by (simp add: rea_top)
  finally show ?thesis .
qed

lemma rea_bottom: "\<^bold>\<bottom>\<^sub>r = R1($wait \<Rightarrow> II)"
proof -
  have "\<^bold>\<bottom>\<^sub>r = RP(true)"
    by (simp add: rea_theory.healthy_bottom)
  also have "... = R1($wait \<Rightarrow> II)"
    by (rel_auto, metis minus_zero_eq)
  finally show ?thesis .
qed

end


(* A particular case of the second calculus, with policy constant on types: *)
theory Mcalc2C
imports Mcalc2
begin

subsection{* Constant policy on types *}

text{* Currently our soundness proof only covers the case of the calculus
having different extension policies for different predicates, but not
for differnt types versus the same predicate. This is sufficient for our purpose
of proving soundness of the guard encodings.  *}

locale ProblemIkPolMcalc2C =
ProblemIkPolMcalc2 wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and pol and grdOf
+ assumes pol_ct: "pol \<sigma>1 P = pol \<sigma>2 P"

context ProblemIkPolMcalc2C begin

definition "polC \<equiv> pol any"

lemma pol_polC: "pol \<sigma> P = polC P"
unfolding polC_def using pol_ct by auto

lemma nv2L_simps[simp]:
"nv2L (Pos (Pr p Tl)) = (case polC p of Fext \<Rightarrow> \<Union> set (map nv2T Tl) |_ \<Rightarrow> {})"
"nv2L (Neg (Pr p Tl)) = (case polC p of Text \<Rightarrow> \<Union> set (map nv2T Tl) |_ \<Rightarrow> {})"
by (auto split: epol.splits simp: pol_polC)

declare nv2L.simps(3,4)[simp del]

lemma isGuard_simps[simp]:
"isGuard x (Pos (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> set (map nv2T Tl) \<and> polC p = Text"
"isGuard x (Neg (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> set (map nv2T Tl) \<and> polC p = Fext"
by (auto simp: pol_polC)

declare isGuard.simps(3,4)[simp del]

end (* context  ProblemIkPolMcalc2 *)

locale ModelIkPolMcalc2C =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkPolMcalc2C wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp pol and grdOf and intT and intF and intP

subsection{* Extension of a structure to an infinte structure
by adding indistinguishable elements *}

context ModelIkPolMcalc2C begin

(* The projection from univ to a structure: *)
definition proj where "proj \<sigma> a \<equiv> if intT \<sigma> a then a else pickT \<sigma>"

lemma intT_proj[simp]: "intT \<sigma> (proj \<sigma> a)"
unfolding proj_def using pickT by auto

lemma proj_id[simp]: "intT \<sigma> a \<Longrightarrow> proj \<sigma> a = a"
unfolding proj_def by auto

lemma map_proj_id[simp]:
assumes "list_all2 intT \<sigma>l al"
shows "map2 proj \<sigma>l al = al"
apply(rule nth_equalityI)
using assms unfolding list_all2_length by auto

lemma surj_proj:
assumes "intT \<sigma> a"   shows "\<exists> b. proj \<sigma> b = a"
using assms by (intro exI[of _ a]) simp

definition "I_intT \<sigma> (a::univ) \<equiv> infTp \<sigma> \<longrightarrow> intT \<sigma> a"
definition "I_intF f al \<equiv> intF f (map2 proj (arOf f) al)"
definition
"I_intP p al \<equiv>
 case polC p of
   Cext \<Rightarrow> intP p (map2 proj (parOf p) al)
  |Text \<Rightarrow> if list_all2 intT (parOf p) al then intP p al else True
  |Fext \<Rightarrow> if list_all2 intT (parOf p) al then intP p al else False"

lemma not_infTp_I_intT[simp]: "\<not> infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a"
unfolding I_intT_def by simp

lemma infTp_I_intT[simp]: "infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a = intT \<sigma> a"
unfolding I_intT_def by simp

lemma NE_I_intT: "NE (I_intT \<sigma>)"
using NE_intT by (cases "infTp \<sigma>", auto)

lemma I_intP_Cext[simp]:
"polC p = Cext \<Longrightarrow> I_intP p al = intP p (map2 proj (parOf p) al)"
unfolding I_intP_def by simp

lemma I_intP_Text_imp[simp]:
assumes "polC p = Text" and "intP p al"
shows "I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intP_Fext_imp[simp]:
assumes "polC p = Fext" and "\<not> intP p al"
shows "\<not> I_intP p al"
using assms unfolding I_intP_def by (cases "list_all2 intT (parOf p) al", auto)

lemma I_intP_intT[simp]:
assumes "list_all2 intT (parOf p) al"
shows "I_intP p al = intP p al"
using assms unfolding I_intP_def by (cases "polC p") auto

lemma I_intP_Text_not_intT[simp]:
assumes "polC p = Text" and "\<not> list_all2 intT (parOf p) al"
shows "I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intP_Fext_not_intT[simp]:
assumes "polC p = Fext" and "\<not> list_all2 intT (parOf p) al"
shows "\<not> I_intP p al"
using assms unfolding I_intP_def by auto

lemma I_intF:
assumes f: "wtFsym f" and al: "list_all2 I_intT (arOf f) al"
shows "I_intT (resOf f) (I_intF f al)"
unfolding I_intT_def I_intF_def apply safe apply(rule intF[OF f])
using al unfolding list_all2_length by auto

lemma Tstruct_I_intT: "Tstruct I_intT"
apply default using NE_I_intT .

lemma inf_I_intT: "infinite {a. I_intT \<sigma> a}"
by (cases "infTp \<sigma>", auto)

lemma InfStruct: "IInfStruct I_intT I_intF I_intP"
apply default using NE_I_intT I_intF Tstruct_I_intT inf_I_intT by auto

end (* context ModelIkPolMcalc2C *)

sublocale ModelIkPolMcalc2C < InfStruct where
intT = I_intT and intF = I_intF and intP = I_intP
using InfStruct .

subsection{* The soundness of the calculus *}

(* In what follows, ``Ik" stands for the original
(augmented with infiniteness-knowledge)
and ``I" for the infinite structure constructed from it
through the above sublocale statement. *)

context ModelIkPolMcalc2C begin
(* The environment translation along the projection: *)
definition "transE \<xi> \<equiv> \<lambda> x. proj (tpOfV x) (\<xi> x)"

lemma wtE_transE[simp]: "I.wtE \<xi> \<Longrightarrow> Ik.wtE (transE \<xi>)"
unfolding Ik.wtE_def I.wtE_def transE_def by auto

abbreviation "Ik_intT \<equiv> intT"
abbreviation "Ik_intF \<equiv> intF"
abbreviation "Ik_intP \<equiv> intP"

lemma Ik_intT_int:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and nv2T: "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)"
shows "Ik_intT (Ik.tpOf T) (I.int \<xi> T)"
proof(cases "\<exists> x. T = Var x")
  case True then obtain x where T: "T = Var x" by auto
  show ?thesis proof(cases "infTp (tpOf T)")
    case True thus ?thesis using T using wtE_transE[OF \<xi>]
    by (metis I.wt_int I_intT_def \<xi> wt)
  next
    case False hence "\<forall> x \<in> nv2T T. tpOfV x \<noteq> tpOf T" using nv2T by auto
    hence "Ik.full (tpOf T)" using T by (cases T, simp_all)
    thus ?thesis unfolding Ik.full_def by simp
  qed
next
  case False hence nonVar: "\<not> (\<exists> x. T = Var x)" by (cases T, auto)
  thus ?thesis using nonVar wt apply(induct T, force)
  unfolding I_intF_def tpOf.simps int.simps
  apply(rule Ik.intF, simp) apply(rule listAll2_map2I) by auto
qed

lemma int_transE_proj:
assumes wt: "Ik.wt T"
shows "Ik.int (transE \<xi>) T = proj (tpOf T) (I.int \<xi> T)"
using wt proof (induct T)
  case (Fn f Tl)
  have 0: "Ik_intT (resOf f) (I_intF f (map (int \<xi>) Tl))" (is "Ik_intT ?\<sigma> ?a")
  unfolding I_intF_def apply(rule Ik.intF)
  using Fn unfolding list_all2_length list_all_iff by auto
  have 1: "proj ?\<sigma> ?a = ?a" using proj_id[OF 0] .
  show ?case
  unfolding Ik.int.simps int.simps tpOf.simps 1
  unfolding I_intF_def apply(rule arg_cong[of _ _ "intF f"])
  proof (rule nth_equalityI, safe)
    have l[simp]: "length (arOf f) = length Tl" using Fn by simp
    fix i assume "i < length (map (Ik.int (transE \<xi>)) Tl)"
    hence i[simp]: "i < length Tl" by simp
    have 0: "arOf f ! i = tpOf (Tl ! i)" using Fn by simp
    have [simp]: "Ik.int (transE \<xi>) (Tl ! i) = proj (arOf f ! i) (I.int \<xi> (Tl ! i))"
    unfolding 0 using Fn by (auto simp: list_all_length transE_def)
    show "map (Ik.int (transE \<xi>)) Tl ! i =
          map2 proj (arOf f) (map (I.int \<xi>) Tl) ! i"
    using Fn unfolding list_all_length by simp
  qed(insert Fn, simp)
qed simp

lemma int_transE_nv2T:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and nv2T: "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
unfolding int_transE_proj[OF wt] apply(rule proj_id)
using Ik_intT_int[OF wt \<xi> nv2T] .

lemma isGuard_not_satL_intT:
assumes wtL: "Ik.wtL l"
and (* crucial hypothesis--the essence of guarding:*) ns: "\<not> I.satL \<xi> l"
and g: "isGuard x l" and \<xi>: "I.wtE \<xi>"
shows "Ik_intT (tpOfV x) (\<xi> x)" (is "Ik_intT ?\<sigma> (\<xi> x)")
(* "proj \<sigma> (\<xi> \<sigma> x) = \<xi> \<sigma> x" *)
(* "Ik.int (transE \<xi>) (Var \<sigma> x) = I.int \<xi> (Var \<sigma> x)" *)
proof(cases l)
  case (Pos at)  show ?thesis proof(cases at)
    case (Pr p Tl)
    then obtain T where Tin: "T \<in> set Tl" and x: "x \<in> nv2T T" and pol: "polC p = Text"
    using g unfolding Pos Pr by auto
    hence T: "T = Var x" by (simp add: in_nv2T)
    obtain i where i: "i < length Tl" and Ti: "T = Tl!i" using Tin
    by (metis in_set_conv_nth)
    hence 0 : "wt T" "parOf p ! i = ?\<sigma>" using wtL unfolding Pos Pr T
    apply (simp_all add: list_all_iff) by (metis T x in_nv2T tpOf.simps)
    have "list_all2 Ik_intT (parOf p) (map (I.int \<xi>) Tl)" (is ?phi)
    using ns unfolding Pos Pr using pol by (cases ?phi, auto)
    hence "Ik_intT ?\<sigma> (I.int \<xi> T)"
    using ns 0 i Ti unfolding Pos Pr by (auto simp add: list_all2_length nth_map)
    thus ?thesis unfolding T by simp
  qed(insert g, unfold Pos, simp)
next
  case (Neg at)  show ?thesis proof(cases at)
    case (Eq T1 T2)
    hence 0: "T1 = Var x \<or> T2 = Var x" using g unfolding Neg by auto
    hence wt1: "Ik.wt T1" "Ik.tpOf T1 = tpOfV x"
    and wt2: "Ik.wt T2" "Ik.tpOf T2 = tpOfV x"
    using wtL unfolding Neg Eq by auto
    have eq: "I.int \<xi> T1 = I.int \<xi> T2" using ns unfolding Neg Eq by simp
    show ?thesis proof(cases "T1 = Var x")
      case True note T1 = True obtain f Tl where "T2 = Fn f Tl"
      using g T1 Eq unfolding Neg by auto
      hence "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nv2T T2. tpOfV x \<noteq> \<sigma>)" by auto
      hence 1: "I.int \<xi> T2 = Ik.int (transE \<xi>) T2" using int_transE_nv2T wt2 \<xi> by auto
      have "Ik_intT ?\<sigma> (I.int \<xi> T1)" unfolding eq 1 using wt2 \<xi> Ik.wt_int by force
      thus ?thesis unfolding T1 by simp
    next
      case False then obtain f Tl where T2: "T2 = Var x" and "T1 = Fn f Tl"
      using Eq Neg g by auto
      hence "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nv2T T1. tpOfV x \<noteq> \<sigma>)" by simp
      hence 1: "I.int \<xi> T1 = Ik.int (transE \<xi>) T1" using int_transE_nv2T wt1 \<xi> by auto
      have "Ik_intT ?\<sigma> (I.int \<xi> T2)" unfolding eq[symmetric] 1
      using wt1 \<xi> Ik.wt_int by force
      thus ?thesis unfolding T2 by simp
    qed
  next
    case (Pr p Tl)
    then obtain T where Tin: "T \<in> set Tl" and x: "x \<in> nv2T T" and pol: "polC p = Fext"
    using g unfolding Neg Pr by auto
    hence T: "T = Var x" by (simp add: in_nv2T)
    obtain i where i: "i < length Tl" and Ti: "T = Tl!i" using Tin
    by (metis in_set_conv_nth)
    hence 0 : "wt T" "parOf p ! i = ?\<sigma>" using wtL unfolding Neg Pr T
    apply (simp_all add: list_all_iff) by (metis T x in_nv2T tpOf.simps)
    have "list_all2 Ik_intT (parOf p) (map (I.int \<xi>) Tl)" (is ?phi)
    using ns unfolding Neg Pr using pol by (cases ?phi, auto)
    hence "Ik_intT ?\<sigma> (I.int \<xi> T)"
    using ns 0 i Ti unfolding Neg Pr by (auto simp add: list_all2_length nth_map)
    thus ?thesis unfolding T by simp
  qed
qed

lemma int_transE[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
proof(cases "infTp (Ik.tpOf T) \<or> (\<forall> x \<in> nv2T T. tpOfV x \<noteq> Ik.tpOf T)")
  case True thus ?thesis using int_transE_nv2T[OF wt \<xi>] by auto
next
  def \<sigma> \<equiv> "Ik.tpOf T"
  case False then obtain x where i: "\<not> infTp \<sigma>" and x: "x \<in> nv2T T"
  unfolding \<sigma>_def by auto
  hence T: "T = Var x" by (simp add: in_nv2T)
  hence \<sigma>: "\<sigma> = tpOfV x" unfolding \<sigma>_def by simp
  obtain l where 0: "Ik.wtL l" "\<not> I.satL \<xi> l" "isGuard x l"
  using nv2T[OF i[unfolded \<sigma>] x] by auto
  show ?thesis unfolding T using isGuard_not_satL_intT[OF 0 \<xi>] by simp
qed

lemma intT_int_transE[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "Ik_intT (Ik.tpOf T) (I.int \<xi> T)"
proof-
  have 0: "I.int \<xi> T = Ik.int (transE \<xi>) T" using int_transE[OF assms] by simp
  show ?thesis unfolding 0 using Ik.wt_int[OF wtE_transE[OF \<xi>] wt] .
qed

lemma map_int_transE_nv2T[simp]:
assumes wt: "list_all Ik.wt Tl" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); \<exists>T\<in>set Tl. x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "map (Ik.int (transE \<xi>)) Tl = map (I.int \<xi>) Tl"
apply(rule nth_equalityI) using assms by (force simp: list_all_iff intro: int_transE)+

lemma list_all2_intT_int_transE_nv2T[simp]:
assumes wt: "list_all Ik.wt Tl" and \<xi>: "I.wtE \<xi>" and
nv2T: "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); \<exists>T\<in>set Tl. x \<in> nv2T T\<rbrakk> \<Longrightarrow>
           \<exists> l. Ik.wtL l \<and> \<not> I.satL \<xi> l \<and> isGuard x l"
shows "list_all2 Ik_intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)"
unfolding list_all2_length using assms
unfolding list_all_iff apply simp_all by (metis intT_int_transE nth_mem)

lemma map_proj_transE[simp]:
assumes wt: "list_all wt Tl"
shows "map (Ik.int (transE \<xi>)) Tl =
       map2 proj (map tpOf Tl) (map (I.int \<xi>) Tl)"
apply(rule nth_equalityI) using assms
using int_transE_proj unfolding list_all_length by auto

lemma satL_transE[simp]:
assumes wtL: "Ik.wtL l" and \<xi>: "I.wtE \<xi>" and
nv2T:  "\<And> x. \<lbrakk>\<not> infTp (tpOfV x); x \<in> nv2L l\<rbrakk> \<Longrightarrow>
             \<exists> l'. Ik.wtL l' \<and> \<not> I.satL \<xi> l' \<and> isGuard x l'"
and "Ik.satL (transE \<xi>) l"
shows "I.satL \<xi> l"
proof(cases l)
  case (Pos at) show ?thesis proof (cases at)
    case (Pr p Tl) show ?thesis using assms unfolding Pos Pr
    apply(cases "polC p")
      apply force
      apply(cases "list_all2 intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)", force, force)
      by simp
  qed(insert assms, unfold Pos, simp)
next
  case (Neg at) show ?thesis proof (cases at)
    case (Pr p Tl) show ?thesis using assms unfolding Neg Pr
    apply(cases "polC p")
      apply force apply force
      by (cases "list_all2 intT (map Ik.tpOf Tl) (map (I.int \<xi>) Tl)", force, force)
  qed(insert assms int_transE_proj, unfold Neg, auto)
qed

lemma satPB_transE[simp]:
assumes \<xi>: "I.wtE \<xi>"  shows "I.satPB \<xi> \<Phi>"
unfolding I.satPB_def proof safe
  fix c assume cin: "c \<in> \<Phi>"  let ?thesis = "I.satC \<xi> c"
  have mc: "\<And> \<sigma>. \<sigma> \<turnstile>2 c" using mcalc2[OF cin] .
  have c: "Ik.satC (transE \<xi>) c"
  using sat_\<Phi> wtE_transE[OF \<xi>] cin unfolding Ik.satPB_def by auto
  have wtC: "Ik.wtC c" using wt_\<Phi> cin unfolding wtPB_def by auto
  obtain l where lin: "l \<in> set c" and l: "Ik.satL (transE \<xi>) l"
  using c unfolding Ik.satC_iff_set by auto
  have wtL: "Ik.wtL l" using wtC unfolding wtC_def
  by (metis (lifting) lin list_all_iff)
  {assume "\<not> ?thesis"
   hence 0: "\<And> l'. l' \<in> set c \<Longrightarrow> \<not> I.satL \<xi> l'" unfolding I.satC_iff_set by auto
   have "I.satL \<xi> l"
   proof (rule satL_transE[OF wtL \<xi> _ l])
     fix x let ?\<sigma> = "tpOfV x"
     assume \<sigma>: "\<not> infTp ?\<sigma>" and x: "x \<in> nv2L l"
     hence g: "isGuard x (grdOf c l x)" using mc[of ?\<sigma>] lin unfolding mcalc2_iff by simp
     show "\<exists> l'. Ik.wtL l' \<and> \<not> I.satL \<xi> l' \<and> isGuard x l'"
     apply(rule exI[of _ "grdOf c l x"]) apply safe
     using g \<sigma> cin lin wtL_grdOf x 0 grdOf x by auto
   qed
   hence False using 0 lin by auto
   hence ?thesis by simp
  }
  thus ?thesis by auto
qed

lemma I_SAT: "I.SAT \<Phi>"
unfolding I.SAT_def by simp

lemma InfModel: "IInfModel I_intT I_intF I_intP"
apply default using I_SAT .

end (* context ModelIkPolMcalc2C *)

sublocale ModelIkPolMcalc2C < InfModel where
intT = I_intT and intF = I_intF and intP = I_intP
using InfModel .

context ProblemIkPolMcalc2C begin

abbreviation
"MModelIkPolMcalc2C \<equiv> ModelIkPolMcalc2C wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf"

end (* context ProblemIkPolMcalc2 *)

text{* Final theorem in sublocale form: Any problem that passes the
  monotonicity calculus is monotonic:  *}
sublocale ProblemIkPolMcalc2C < MonotProblem
apply default using monot .

end