section \<open> Reactive Relations \<close>

theory utp_rea_rel
  imports
    utp_rea_healths
    (* "utp_kleene" *)
begin

text \<open> This theory defines a reactive relational calculus for @{term R1}-@{term R2} predicates as an
  extension of the standard alphabetised predicate calculus. This enables us to formally characterise
  relational programs that refer to both state variables and a trace history. For more details on
  reactive relations, please see the associated journal paper~\cite{Foster17c}. \<close>

subsection \<open> Healthiness Conditions \<close>

definition RR :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "RR(P) = (\<Sqinter> k k' w w' :: bool. (R2 P)\<lbrakk>\<guillemotleft>k\<guillemotright>,\<guillemotleft>k'\<guillemotright>,\<guillemotleft>w\<guillemotright>,\<guillemotleft>w'\<guillemotright>/ok\<^sup><,ok\<^sup>>,wait\<^sup><,wait\<^sup>>\<rbrakk>)"

expr_constructor RR

lemma RR_idem: "RR(RR(P)) = RR(P)"
  by pred_auto

lemma RR_Idempotent [closure]: "Idempotent RR"
  by (simp add: Idempotent_def RR_idem)

lemma RR_Continuous [closure]: "Continuous RR"
  by (pred_auto; blast)

lemma R1_RR: "R1(RR(P)) = RR(P)"
  by pred_auto

lemma R2c_RR: "R2c(RR(P)) = RR(P)"
  by pred_auto

lemma RR_implies_R1 [closure]: "P is RR \<Longrightarrow> P is R1"
  by (metis Healthy_def R1_RR)

lemma RR_implies_R2c: "P is RR \<Longrightarrow> P is R2c"
  by (metis Healthy_def R2c_RR)

lemma RR_implies_R2 [closure]: "P is RR \<Longrightarrow> P is R2"
  by (metis Healthy_def R1_RR R2_R2c_def R2c_RR)

(* TODO: is it possible to use a shorter simplifier proof as in UTP1? *)
lemma RR_intro:
  assumes "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P" "P is R1" "P is R2c"
  shows "P is RR"
proof (unfold Healthy_def)
  have "RR P = (\<Sqinter>k k' w w'. [ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> (R2s P \<triangleleft> (tr\<^sup>< \<le> tr\<^sup>>) \<triangleright> (P \<and> (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)))"
    by (simp add: RR_def Healthy_def R2_R2c_def R1_def R2c_def R2s_def)
       (pred_auto; meson)
  also have "\<dots> = (\<Sqinter>k k' w w'. ([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> R2s P) \<triangleleft> ([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> (tr\<^sup>< \<le> tr\<^sup>>)) \<triangleright> ([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> (P \<and> (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)))"
    by pred_auto
  also have "\<dots> = (\<Sqinter>k k' w w'. ([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> R2s P) \<triangleleft> (tr\<^sup>< \<le> tr\<^sup>>) \<triangleright> ([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> P) \<and> (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)"
    by (pred_auto)
  also have "\<dots> = (\<Sqinter>k k' w w'. R1([ok\<^sup>< \<leadsto> k, ok\<^sup>> \<leadsto> k', wait\<^sup>< \<leadsto> w, wait\<^sup>> \<leadsto> w'] \<dagger> R2s P))"
    by pred_auto
  also have "\<dots> = R1(R2s P)"
    using assms by (pred_auto; meson)
  also have "\<dots> = P"
    using assms unfolding Healthy_def
    by (simp add: R1_R2s_R2c)
  finally show "RR P = P" .
qed

lemma RR_R2_intro:
  assumes "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P" "P is R2"
  shows "P is RR"
proof (unfold Healthy_def)
  have "\<And>k k' k'' k''' w w' w'' w''' t t' m m'.
        P (\<lparr>ok\<^sub>v = k, wait\<^sub>v = w, tr\<^sub>v = t, \<dots> = m\<rparr>, \<lparr>ok\<^sub>v = k', wait\<^sub>v = w', tr\<^sub>v = t', \<dots> = m'\<rparr>)
      = P (\<lparr>ok\<^sub>v = k'', wait\<^sub>v = w'', tr\<^sub>v = t, \<dots> = m\<rparr>, \<lparr>ok\<^sub>v = k''', wait\<^sub>v = w''', tr\<^sub>v = t', \<dots> = m'\<rparr>)"
    using assms apply pred_auto
    by meson+
  hence "RR(P) = R2 P"
    by (pred_auto; blast)
  thus "RR P = P"
    by (simp add: Healthy_if assms(5))
qed

lemma RR_unrests [unrest]:
  assumes "P is RR"
  shows "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P"
proof -
  have "$ok\<^sup>< \<sharp> RR P" "$ok\<^sup>> \<sharp> RR(P)" "$wait\<^sup>< \<sharp> RR(P)" "$wait\<^sup>> \<sharp> RR(P)"
    by (simp_all add: RR_def)
       (pred_auto+)
  thus "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P"
    by (simp_all add: assms Healthy_if)
qed

lemma RR_refine_intro:
  assumes "P is RR" "Q is RR" "\<And> t. P\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<sqsubseteq> Q\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>"
  shows "P \<sqsubseteq> Q"
proof -
  have "\<And> t. (RR P)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<sqsubseteq> (RR Q)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>"
    by (simp add: Healthy_if assms)
  hence "RR(P) \<sqsubseteq> RR(Q)"
    by pred_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma RR_eq_transfer:
  assumes "P is RR" "Q is RR"
    "(\<And> t. [ok\<^sup>< \<leadsto> True, ok\<^sup>> \<leadsto> True, wait\<^sup>< \<leadsto> False, wait\<^sup>> \<leadsto> False, tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> \<guillemotleft>t\<guillemotright>] \<dagger> P
          = [ok\<^sup>< \<leadsto> True, ok\<^sup>> \<leadsto> True, wait\<^sup>< \<leadsto> False, wait\<^sup>> \<leadsto> False, tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> \<guillemotleft>t\<guillemotright>] \<dagger> Q)"
  shows "P = Q"
proof -
  have "(\<And> t. [ok\<^sup>< \<leadsto> True, ok\<^sup>> \<leadsto> True, wait\<^sup>< \<leadsto> False, wait\<^sup>> \<leadsto> False, tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> \<guillemotleft>t\<guillemotright>] \<dagger> RR P
            = [ok\<^sup>< \<leadsto> True, ok\<^sup>> \<leadsto> True, wait\<^sup>< \<leadsto> False, wait\<^sup>> \<leadsto> False, tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> \<guillemotleft>t\<guillemotright>] \<dagger> RR Q)"
    by (metis Healthy_if assms(1) assms(2) assms(3))
  hence "RR P = RR Q"
    by (simp add: RR_def; pred_auto)
  thus ?thesis
    by (metis Healthy_if assms(1) assms(2))
qed

text \<open> Tailored proof strategy for reactive relations -- eliminates irrelevant variables like ok, wait, and tr. \<close>

method rrel_auto uses cls = (rule RR_eq_transfer, simp add: closure cls, simp add: closure cls, rel_auto)

lemma R4_RR_closed [closure]:
  assumes "P is RR"
  shows "R4(P) is RR"
proof -
  have "R4(RR(P)) is RR"
    by pred_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R5_RR_closed [closure]:
  assumes "P is RR"
  shows "R5(P) is RR"
proof -
  have "R5(RR(P)) is RR"
    using minus_zero_eq by pred_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

subsection \<open> Reactive relational operators \<close>

named_theorems rpred

abbreviation rea_true :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" ("true\<^sub>r") where
"true\<^sub>r \<equiv> R1(true)"

definition rea_not :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" ("\<not>\<^sub>r _" [40] 40)
  where [pred]: "(\<not>\<^sub>r P) = R1(\<not> P)"

expr_constructor rea_not

definition rea_diff :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" (infixl "-\<^sub>r" 65)
where [pred]: "rea_diff P Q = (P \<and> \<not>\<^sub>r Q)"

expr_constructor rea_diff

definition rea_impl ::
  "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" (infixr "\<longrightarrow>\<^sub>r" 25)
where [pred]: "(P \<longrightarrow>\<^sub>r Q) = (\<not>\<^sub>r P \<or> Q)"

expr_constructor rea_impl

definition rea_lift :: "('t::trace,'\<alpha>,'\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" ("[_]\<^sub>r")
where [pred]: "[P]\<^sub>r = R1(P)"

expr_constructor rea_lift

definition rea_skip :: "('t::trace,'\<alpha>) hrel_rp" ("II\<^sub>r")
where [pred]: "II\<^sub>r = (tr\<^sup>> = tr\<^sup>< \<and> \<^bold>v\<^sub>R\<^sup>> = \<^bold>v\<^sub>R\<^sup><)\<^sub>e"

expr_constructor rea_skip

definition rea_assert :: "('t::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t,'\<alpha>) hrel_rp" ("{_}\<^sub>r")
where [pred]: "{b}\<^sub>r = (II\<^sub>r \<or> \<not>\<^sub>r b)"

expr_constructor rea_assert

text \<open> Convert from one trace algebra to another using renamer functions, which are a kind of
  monoid homomorphism. \<close>

locale renamer =
  fixes f :: "'a::trace \<Rightarrow> 'b::trace"
  assumes
    injective: "inj f" and
    add: "f (x + y) = f x + f y"
begin
  lemma zero: "f 0 = 0"
    by (metis add add.right_neutral add_monoid_diff_cancel_left)

  lemma minus: "x \<le> y \<Longrightarrow> f (y - x) = f(y) - f(x)"
    by (metis add diff_add_cancel_left' trace_class.add_diff_cancel_left)
end

declare renamer.add [simp]
declare renamer.zero [simp]
declare renamer.minus [simp]

lemma renamer_id: "renamer id"
  by (unfold_locales, simp_all)

lemma renamer_comp: "\<lbrakk> renamer f; renamer g \<rbrakk> \<Longrightarrow> renamer (f \<circ> g)"
  by (unfold_locales, simp_all add: inj_compose renamer.injective)

lemma renamer_map: "inj f \<Longrightarrow> renamer (map f)"
  by (unfold_locales, simp_all add: plus_list_def)

definition rea_rename :: "('t\<^sub>1::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t\<^sub>1 \<Rightarrow> 't\<^sub>2) \<Rightarrow> ('t\<^sub>2::trace,'\<alpha>) hrel_rp" ("(_)\<lparr>_\<rparr>\<^sub>r" [999, 0] 999) where
[pred]: "rea_rename P f = R2(((tr\<^sup>> = 0) \<and> \<^bold>v\<^sub>R\<^sup>> = \<^bold>v\<^sub>R\<^sup><)\<^sub>e ;; P ;; (tr\<^sup>> = \<guillemotleft>f\<guillemotright> (tr\<^sup><) \<and> \<^bold>v\<^sub>R\<^sup>> = \<^bold>v\<^sub>R\<^sup><)\<^sub>e)"

text \<open> Trace contribution substitution: make a substitution for the trace contribution lens
  @{term tt}, and apply @{term R1} to make the resulting predicate healthy again. \<close>

definition rea_subst :: "('t :: trace, '\<alpha>) rp hrel \<Rightarrow> (('t, '\<alpha>) rp \<times> ('t, '\<alpha>) rp \<Rightarrow> 't) \<Rightarrow> ('t, '\<alpha>) rp hrel" ("_\<lbrakk>_\<rbrakk>\<^sub>r" [999,0] 999)
where [pred]: "P\<lbrakk>v\<rbrakk>\<^sub>r = R1(P\<lbrakk>v/tt\<rbrakk>)\<^sub>e"

subsection \<open> Unrestriction and substitution laws \<close>

find_theorems "?x \<in>\<^sub>v ?y"

lemma rea_true_unrest [unrest]:
  assumes "mwb_lens x" "x \<bowtie> (ns_alpha fst\<^sub>L tr)" "x \<bowtie> (ns_alpha snd\<^sub>L tr)"
  shows "$x \<sharp> true\<^sub>r"
  by (simp add: R1_unrest assms unrest_pred)

lemma rea_not_unrest [unrest]:
  assumes "mwb_lens x" "x \<bowtie> (ns_alpha fst\<^sub>L tr)" "x \<bowtie> (ns_alpha snd\<^sub>L tr)" "$x \<sharp> P"
  shows "$x \<sharp> \<not>\<^sub>r P"
  using assms by (simp add: rea_not_def unrest_pred ns_alpha_def R1_unrest)

lemma rea_impl_unrest [unrest]:
  assumes "mwb_lens x" "x \<bowtie> (ns_alpha fst\<^sub>L tr)" "x \<bowtie> (ns_alpha snd\<^sub>L tr)" "$x \<sharp> P" "$x \<sharp> Q"
  shows "$x \<sharp> P \<longrightarrow>\<^sub>r Q"
  using assms by (simp add: rea_impl_def unrest)

lemma rea_true_usubst [usubst]:
  "\<lbrakk> $tr\<^sup>< \<sharp>\<^sub>s \<sigma>; $tr\<^sup>> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> true\<^sub>r = true\<^sub>r"
  by (simp add: R1_def usubst usubst_apply_unrest)

lemma rea_not_usubst [usubst]:
  "\<lbrakk> $tr\<^sup>< \<sharp>\<^sub>s \<sigma>; $tr\<^sup>> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (\<not>\<^sub>r P) = (\<not>\<^sub>r \<sigma> \<dagger> P)"
  by (simp add: rea_not_def R1_def usubst usubst_apply_unrest)

lemma rea_impl_usubst [usubst]:
  "\<lbrakk> $tr\<^sup>< \<sharp>\<^sub>s \<sigma>; $tr\<^sup>> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (P \<longrightarrow>\<^sub>r Q) = (\<sigma> \<dagger> P \<longrightarrow>\<^sub>r \<sigma> \<dagger> Q)"
  by (simp add: rea_impl_def usubst R1_def)

lemma rea_true_usubst_tt [usubst]:
  "R1(true)\<lbrakk>e/tt\<rbrakk> = true"
  by pred_auto

lemma unrests_rea_rename [unrest]:
  "$ok\<^sup>< \<sharp> P \<Longrightarrow> $ok\<^sup>< \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$ok\<^sup>> \<sharp> P \<Longrightarrow> $ok\<^sup>> \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$wait\<^sup>< \<sharp> P \<Longrightarrow> $wait\<^sup>< \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$wait\<^sup>> \<sharp> P \<Longrightarrow> $wait\<^sup>< \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  by pred_auto+

lemma unrest_rea_subst [unrest]:
  assumes "mwb_lens x" "x \<bowtie> (ns_alpha fst\<^sub>L tr)" "x \<bowtie> (ns_alpha snd\<^sub>L tr)" "$x \<sharp> v" "$x \<sharp> P"
  shows "$x \<sharp> (P\<lbrakk>v\<rbrakk>\<^sub>r)"
proof -
  have "$x \<sharp> P\<lbrakk>v/tt\<rbrakk>"
    (* TODO: is there a non-SMT proof of this *)
    by (smt (verit) SEXP_def assms lens_indep.lens_put_comm subst_id_def subst_upd_def tt_indeps(2) unrest_lens unrest_subst_apply unrest_subst_lens)
  thus ?thesis
    using assms by (metis R1_unrest SEXP_def rea_subst_def)
qed

lemma rea_substs [usubst]:
  "true\<^sub>r\<lbrakk>v\<rbrakk>\<^sub>r = true\<^sub>r" "true\<lbrakk>v\<rbrakk>\<^sub>r = true\<^sub>r" "false\<lbrakk>v\<rbrakk>\<^sub>r = false"
  "(\<not>\<^sub>r P)\<lbrakk>v\<rbrakk>\<^sub>r = (\<not>\<^sub>r P\<lbrakk>v\<rbrakk>\<^sub>r)" "(P \<and> Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<and> Q\<lbrakk>v\<rbrakk>\<^sub>r)" "(P \<or> Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<or> Q\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(P \<longrightarrow>\<^sub>r Q)\<lbrakk>v\<rbrakk>\<^sub>r = (P\<lbrakk>v\<rbrakk>\<^sub>r \<longrightarrow>\<^sub>r Q\<lbrakk>v\<rbrakk>\<^sub>r)"
  by pred_auto+

lemma rea_substs_lattice [usubst]:
  "(\<Sqinter> i. P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Sqinter> i. (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(\<Sqinter> i\<in>A. P(i))\<lbrakk>v\<rbrakk>\<^sub>r = (\<Sqinter> i\<in>A. (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  "(\<Squnion> i. P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Squnion> i. (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
   by pred_auto+

lemma rea_subst_USUP_set [usubst]:
  "A \<noteq> {} \<Longrightarrow> (\<Squnion> i\<in>A. P(i))\<lbrakk>v\<rbrakk>\<^sub>r   = (\<Squnion> i\<in>A. (P(i))\<lbrakk>v\<rbrakk>\<^sub>r)"
  by pred_auto+

subsection \<open> Closure laws \<close>

lemma rea_lift_R1 [closure]: "[P]\<^sub>r is R1"
  by pred_auto

lemma R1_rea_not: "R1(\<not>\<^sub>r P) = (\<not>\<^sub>r P)"
  by pred_auto

lemma R1_rea_not': "R1(\<not>\<^sub>r P) = (\<not>\<^sub>r R1(P))"
  by pred_auto

lemma R2c_rea_not: "R2c(\<not>\<^sub>r P) = (\<not>\<^sub>r R2c(P))"
  by pred_auto

lemma RR_rea_not: "RR(\<not>\<^sub>r RR(P)) = (\<not>\<^sub>r RR(P))"
  by pred_auto

lemma R1_rea_impl: "R1(P \<longrightarrow>\<^sub>r Q) = (P \<longrightarrow>\<^sub>r R1(Q))"
  by pred_auto

lemma R1_rea_impl': "R1(P \<longrightarrow>\<^sub>r Q) = (R1(P) \<longrightarrow>\<^sub>r R1(Q))"
  by pred_auto

lemma R2c_rea_impl: "R2c(P \<longrightarrow>\<^sub>r Q) = (R2c(P) \<longrightarrow>\<^sub>r R2c(Q))"
  by pred_auto

lemma RR_rea_impl: "RR(RR(P) \<longrightarrow>\<^sub>r RR(Q)) = (RR(P) \<longrightarrow>\<^sub>r RR(Q))"
  by pred_auto

lemma rea_true_R1 [closure]: "true\<^sub>r is R1"
  by pred_auto

lemma rea_true_R2c [closure]: "true\<^sub>r is R2c"
  by pred_auto

lemma rea_true_RR [closure]: "true\<^sub>r is RR"
  by pred_auto

lemma rea_not_R1 [closure]: "\<not>\<^sub>r P is R1"
  by pred_auto

lemma rea_not_R2c [closure]: "P is R2c \<Longrightarrow> \<not>\<^sub>r P is R2c"
  by (simp add: Healthy_def rea_not_def R1_R2c_commute[THEN sym] R2c_not)

lemma rea_not_R2_closed [closure]:
  "P is R2 \<Longrightarrow> (\<not>\<^sub>r P) is R2"
  by (simp add: Healthy_def' R1_rea_not' R2_R2c_def R2c_rea_not)

lemma rea_no_RR [closure]:
  "\<lbrakk> P is RR \<rbrakk> \<Longrightarrow> (\<not>\<^sub>r P) is RR"
  by (metis Healthy_def' RR_rea_not)

lemma rea_impl_R1 [closure]:
  "Q is R1 \<Longrightarrow> (P \<longrightarrow>\<^sub>r Q) is R1"
  by (pred_auto; blast)

lemma rea_impl_R2c [closure]:
  "\<lbrakk> P is R2c; Q is R2c \<rbrakk> \<Longrightarrow> (P \<longrightarrow>\<^sub>r Q) is R2c"
  by (simp add: rea_impl_def Healthy_def rea_not_def R1_R2c_commute[THEN sym] R2c_not R2c_disj)

lemma rea_impl_R2 [closure]:
  "\<lbrakk> P is R2; Q is R2 \<rbrakk> \<Longrightarrow> (P \<longrightarrow>\<^sub>r Q) is R2"
  by (pred_auto; blast)

lemma rea_impl_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<longrightarrow>\<^sub>r Q) is RR"
  by (metis Healthy_def' RR_rea_impl)

lemma conj_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<and> Q) is RR"
  by (meson RR_implies_R1 RR_implies_R2c RR_intro RR_unrests conj_R1_closed_1 conj_R2c_closed unrest_pred)

lemma disj_RR [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> (P \<or> Q) is RR"
  by (metis Healthy_def' R1_RR R1_idem R1_rea_not' RR_rea_impl RR_rea_not pred_ba.boolean_algebra.double_compl rea_impl_def rea_not_def)

lemma USUP_mem_RR_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RR" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A. P(i)) is RR"
proof -
  have 1:"(\<Squnion> i\<in>A. P(i)) is R1"
    by (unfold Healthy_def, subst R1_UINF, simp_all add: Healthy_if assms closure cong: INF_cong)
  have 2:"(\<Squnion> i\<in>A. P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_UINF, simp_all add: Healthy_if assms RR_implies_R2c closure cong: INF_cong)
  show ?thesis
    using 1 2 by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma USUP_ind_RR_closed [closure]:
  assumes "\<And> i. P i is RR"
  shows "(\<Squnion> i. P(i)) is RR"
  using USUP_mem_RR_closed[of UNIV P] by (simp add: assms)

lemma UINF_mem_RR_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RR"
  shows "(\<Sqinter> i\<in>A. P(i)) is RR"
proof -
  have 1:"(\<Sqinter> i\<in>A. P(i)) is R1"
    by (unfold Healthy_def, subst R1_USUP, simp add: Healthy_if RR_implies_R1 assms cong: SUP_cong)
  have 2:"(\<Sqinter> i\<in>A. P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_USUP, simp add: Healthy_if RR_implies_R2c assms cong: SUP_cong)
  show ?thesis
    using 1 2 by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma UINF_ind_RR_closed [closure]:
  assumes "\<And> i. P i is RR"
  shows "(\<Sqinter> i. P(i)) is RR"
  by (simp add: assms closure)

lemma USUP_elem_RR [closure]:
  assumes "\<And> i. P i is RR" "A \<noteq> {}"
  shows "(\<Squnion> i \<in> A. P i) is RR"
proof -
  have "(\<Squnion> i\<in>A. P(i)) is R1"
    by (unfold Healthy_def, subst R1_UINF, simp_all add: Healthy_if assms closure)
  moreover have "(\<Squnion> i\<in>A. P(i)) is R2c"
    by (unfold Healthy_def, subst R2c_UINF, simp_all add: Healthy_if assms RR_implies_R2c closure)
  ultimately show ?thesis
    by (rule_tac RR_intro, simp_all add: unrest assms)
qed

lemma seq_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P ;; Q is RR"
proof -
  have "P is R2" "Q is R2"
    using RR_implies_R2 assms by blast+
  then have 1: "P ;; Q is R2"
    using R2_seqr_closure by blast
  have "$ok\<^sup>< \<sharp> P" "$wait\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> Q" "$wait\<^sup>> \<sharp> Q"
    using RR_unrests assms by blast+
  then have 2: "$ok\<^sup>< \<sharp> P ;; Q" "$wait\<^sup>< \<sharp> P ;; Q" "$ok\<^sup>> \<sharp> P ;; Q" "$wait\<^sup>> \<sharp> P ;; Q"
    by (metis ok_vwb_lens wait_vwb_lens seqr_liberate_left seqr_liberate_right unrest_liberate_iff)+
  then show ?thesis
    using 1 2 RR_R2_intro by blast
qed

lemma power_Suc_RR_closed [closure]:
  "P is RR \<Longrightarrow> P ;; P \<^bold>^ i is RR"
  by (induct i, simp_all add: closure upred_semiring.power_Suc)

lemma seqr_iter_RR_closed [closure]:
  "\<lbrakk> I \<noteq> []; \<And> i. i \<in> set(I) \<Longrightarrow> P(i) is RR \<rbrakk> \<Longrightarrow> (;; i : I \<bullet> P(i)) is RR"
  apply (induct I, simp_all)
  apply (rename_tac i I)
  apply (case_tac I)
  apply (simp_all add: seq_RR_closed)
  done

find_theorems "unrest ?x (?P \<and> ?Q)"
find_theorems "unrest ?x (\<not> ?P)"
find_theorems "unrest ?x (?P \<or> ?Q)"
find_theorems "_ \<triangleleft> _ \<triangleright> _"
find_theorems "(_ \<or> _) is _"

(* TODO (Thomas): belongs in UTP *)
lemma unrest_cond [unrest]:
  assumes "mwb_lens x" "$x \<sharp> P" "$x \<sharp> Q" "$x \<sharp> (e)\<^sub>e"
  shows "$x \<sharp> (P \<triangleleft> e \<triangleright> Q)"
  using assms(1) assms(4) apply(pred_auto)
  using unrest_lens assms(2-3) by blast+

(* TODO (Thomas): there should be a much simpler proof of this;
   why are the simplifier and unrest not more help? *)
lemma cond_tt_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P \<triangleleft> tr\<^sup>> = tr\<^sup>< \<triangleright> Q is RR" (is "?PQ is RR")
proof -
  have 1: "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P"  "$ok\<^sup>< \<sharp> Q" "$ok\<^sup>> \<sharp> Q" "$wait\<^sup>< \<sharp> Q" "$wait\<^sup>> \<sharp> Q"
    using assms RR_unrests by blast+
  have 2: "$ok\<^sup>< \<sharp> (tr\<^sup>> = tr\<^sup><)\<^sub>e"  "$ok\<^sup>> \<sharp> (tr\<^sup>> = tr\<^sup><)\<^sub>e" "$wait\<^sup>< \<sharp> (tr\<^sup>> = tr\<^sup><)\<^sub>e" "$wait\<^sup>> \<sharp> (tr\<^sup>> = tr\<^sup><)\<^sub>e"
    by pred_auto+
  have 3: "$ok\<^sup>< \<sharp> ?PQ" "$ok\<^sup>> \<sharp> ?PQ" "$wait\<^sup>< \<sharp> ?PQ" "$wait\<^sup>> \<sharp> ?PQ"
    by (simp_all add: unrest_cond 1 2)
  have 4: "R2(P) = P" "R2(Q) = Q"
    using assms RR_implies_R2 Healthy_def by blast+
  have 5: "?PQ is R2"
    apply(simp add: Healthy_def)
    apply(subst R2_condr)
    (* The simplifier proof seems to be being held up the difference between
       (tr\<^sup>> = tr\<^sup><)\<^sub>e and (\<lambda>\<s>. ($tr)\<^sup>> \<s> = ($tr)\<^sup>< \<s>) *)
    by (metis (mono_tags, lifting) "4" R2_tr'_minus_tr SEXP_def)
  from 3 5 show ?thesis
    using RR_R2_intro by blast
qed

lemma rea_skip_RR [closure]:
  "II\<^sub>r is RR"
  apply pred_auto using minus_zero_eq by blast

lemma tr_eq_tr'_RR_closed [closure]: "(tr\<^sup>< = tr\<^sup>>)\<^sub>e is RR"
  apply pred_auto using minus_zero_eq by auto

lemma tr'_eq_tr_RR_closed [closure]: "(tr\<^sup>> = tr\<^sup><)\<^sub>e is RR"
  apply pred_auto using minus_zero_eq by auto

lemma inf_RR_closed [closure]:
  "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> P \<sqinter> Q is RR"
  by (metis disj_RR disj_pred_def)

lemma conj_tr_strict_RR_closed [closure]:
  assumes "P is RR"
  shows "(P \<and> (tr\<^sup>< < tr\<^sup>>)\<^sub>e) is RR"
proof -
  have "RR(RR(P) \<and> (tr\<^sup>< < tr\<^sup>>)\<^sub>e) = (RR(P) \<and> (tr\<^sup>< < tr\<^sup>>)\<^sub>e)"
    by pred_auto
  thus ?thesis
    by (metis (no_types, lifting) Healthy_def assms)
qed

lemma rea_assert_RR_closed [closure]:
  assumes "b is RR"
  shows "{b}\<^sub>r is RR"
  by (simp add: closure assms rea_assert_def)

lemma upower_RR_closed [closure]:
  "\<lbrakk> i > 0; P is RR \<rbrakk> \<Longrightarrow> P \<^bold>^ i is RR"
  apply (induct i, simp_all)
  apply (rename_tac i)
  apply (case_tac "i = 0")
   apply (simp_all add: closure upred_semiring.power_Suc)
  done

lemma seq_power_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "(P \<^bold>^ i) ;; Q is RR"
  by (metis assms neq0_conv seq_RR_closed seqr_left_unit upower_RR_closed upred_semiring.power_0)

(*
lemma ustar_right_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P ;; Q\<^sup>\<star> is RR"
proof -
  have "P ;; Q\<^sup>\<star> = P ;; (\<Sqinter> i \<in> {0..} \<bullet> Q \<^bold>^ i)"
    by (simp add: ustar_def)
  also have "... = P ;; (II \<sqinter> (\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i))"
    by (metis One_nat_def UINF_atLeast_first upred_semiring.power_0)
  also have "... = (P \<or> P ;; (\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i))"
    by (simp add: disj_upred_def[THEN sym] seqr_or_distr)
  also have "... is RR"
  proof -
    have "(\<Sqinter> i \<in> {1..} \<bullet> Q \<^bold>^ i) is RR"
      by (rule UINF_mem_Continuous_closed, simp_all add: assms closure)
    thus ?thesis
      by (simp add: assms closure)
  qed
  finally show ?thesis .
qed

lemma ustar_left_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P\<^sup>\<star> ;; Q is RR"
proof -
  have "P\<^sup>\<star> ;; Q = (\<Sqinter> i \<in> {0..} \<bullet> P \<^bold>^ i) ;; Q"
    by (simp add: ustar_def)
  also have "... = (II \<sqinter> (\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i)) ;; Q"
    by (metis One_nat_def UINF_atLeast_first upred_semiring.power_0)
  also have "... = (Q \<or> (\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i) ;; Q)"
    by (simp add: disj_upred_def[THEN sym] seqr_or_distl)
  also have "... is RR"
  proof -
    have "(\<Sqinter> i \<in> {1..} \<bullet> P \<^bold>^ i) is RR"
      by (rule UINF_mem_Continuous_closed, simp_all add: assms closure)
    thus ?thesis
      by (simp add: assms closure)
  qed
  finally show ?thesis .
qed

lemma uplus_RR_closed [closure]: "P is RR \<Longrightarrow> P\<^sup>+ is RR"
  by (simp add: uplus_def ustar_right_RR_closed)
*)

(* TODO: should hold for an arbitrary trace algebra *)
lemma trace_ext_prefix_RR [closure]: "$tr\<^sup>< \<sharp> e \<Longrightarrow> $ok\<^sup>< \<sharp> e \<Longrightarrow> $wait\<^sup>< \<sharp> e \<Longrightarrow> out\<alpha> \<sharp> e \<Longrightarrow> (($tr)\<^sup>< @ e \<le> ($tr)\<^sup>>)\<^sub>e is RR"
  apply(pred_auto)
  apply (metis (no_types, lifting) Prefix_Order.prefixE Prefix_Order.same_prefix_prefix append_minus append_self_conv2 zero_list_def)
  by (metis (no_types, lifting) Prefix_Order.same_prefix_prefix diff_add_cancel_left' list_append_prefixD plus_list_def self_append_conv2 zero_list_def)

lemma rea_subst_R1_closed [closure]: "P\<lbrakk>v\<rbrakk>\<^sub>r is R1"
  by pred_auto

lemma R5_comp [rpred]:
  assumes "P is RR" "Q is RR"
  shows "R5(P ;; Q) = R5(P) ;; R5(Q)"
proof -
  have "R5(RR(P) ;; RR(Q)) = R5(RR(P)) ;; R5(RR(Q))"
    by (pred_auto; force)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R4_comp [rpred]:
  assumes "P is R4" "Q is RR"
  shows "R4(P ;; Q) = P ;; Q"
proof -
  have "R4(R4(P) ;; RR(Q)) = R4(P) ;; RR(Q)"
    by (pred_auto, blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_rename_RR_closed [closure]:
  assumes "P is RR"
  shows "P\<lparr>f\<rparr>\<^sub>r is RR"
proof -
  have "(RR P)\<lparr>f\<rparr>\<^sub>r is RR"
    by pred_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

subsection \<open> Reactive relational calculus \<close>

lemma rea_skip_unit [rpred]:
  assumes "P is RR"
  shows "P ;; II\<^sub>r = P" "II\<^sub>r ;; P = P"
proof -
  have 1: "RR(P) ;; II\<^sub>r = RR(P)"
    by pred_auto
  have 2: "II\<^sub>r ;; RR(P) = RR(P)"
    by pred_auto
  from 1 2 show "P ;; II\<^sub>r = P" "II\<^sub>r ;; P = P"
    by (simp_all add: Healthy_if assms)
qed

lemma rea_true_conj [rpred]:
  assumes "P is R1"
  shows "(true\<^sub>r \<and> P) = P" "(P \<and> true\<^sub>r) = P"
  using assms apply (metis Healthy_if R1_extend_conj pred_ba.inf_top_left)
  using assms apply (metis Healthy_if R1_conj pred_ba.inf_top.right_neutral)
  done

lemma rea_true_disj [rpred]:
  assumes "P is R1"
  shows "(true\<^sub>r \<or> P) = true\<^sub>r" "(P \<or> true\<^sub>r) = true\<^sub>r"
  apply (metis assms disj_R1_closed pred_ba.inf_sup_absorb rea_true_R1 rea_true_conj(1))
  apply (metis Healthy_if R1_disj assms pred_ba.boolean_algebra.disj_one_right)
  done

lemma rea_not_not [rpred]: "P is R1 \<Longrightarrow> (\<not>\<^sub>r \<not>\<^sub>r P) = P"
  by (simp add: rea_not_def R1_negate_R1 Healthy_if)

lemma rea_not_rea_true [simp]: "(\<not>\<^sub>r true\<^sub>r) = false"
  by (simp add: rea_not_def R1_negate_R1 R1_false)

lemma rea_not_false [simp]: "(\<not>\<^sub>r false) = true\<^sub>r"
  by (simp add: rea_not_def)

lemma rea_true_impl [rpred]:
  "P is R1 \<Longrightarrow> (true\<^sub>r \<longrightarrow>\<^sub>r P) = P"
  by (simp add: rea_not_def rea_impl_def R1_negate_R1 R1_false Healthy_if)

lemma rea_true_impl' [rpred]:
  "P is R1 \<Longrightarrow>(true \<longrightarrow>\<^sub>r P) = P"
  by (simp add: rea_not_def rea_impl_def R1_negate_R1 R1_false Healthy_if)

lemma rea_false_impl [rpred]:
  "P is R1 \<Longrightarrow> (false \<longrightarrow>\<^sub>r P) = true\<^sub>r"
  by (simp add: rea_impl_def rpred Healthy_if)

lemma rea_impl_true [simp]: "(P \<longrightarrow>\<^sub>r true\<^sub>r) = true\<^sub>r"
  by pred_auto

lemma rea_impl_false [simp]: "(P \<longrightarrow>\<^sub>r false) = (\<not>\<^sub>r P)"
  by pred_simp

lemma rea_imp_refl [rpred]: "P is R1 \<Longrightarrow> (P \<longrightarrow>\<^sub>r P) = true\<^sub>r"
  by (pred_auto; blast)

lemma rea_impl_conj [rpred]:
  "(P \<longrightarrow>\<^sub>r Q \<longrightarrow>\<^sub>r R) = ((P \<and> Q) \<longrightarrow>\<^sub>r R)"
  by pred_auto

lemma rea_impl_mp [rpred]:
  "(P \<and> (P \<longrightarrow>\<^sub>r Q)) = (P \<and> Q)"
  by pred_auto

lemma rea_impl_conj_combine [rpred]:
  "((P \<longrightarrow>\<^sub>r Q) \<and> (P \<longrightarrow>\<^sub>r R)) = (P \<longrightarrow>\<^sub>r Q \<and> R)"
  by pred_auto

lemma rea_impl_alt_def:
  assumes "Q is R1"
  shows "(P \<longrightarrow>\<^sub>r Q) = R1(P \<longrightarrow> Q)"
proof -
  have "(P \<longrightarrow>\<^sub>r R1(Q)) = R1(P \<longrightarrow> Q)"
    by pred_auto
  thus ?thesis
    by (simp add: assms Healthy_if)
qed

lemma rea_impl_disj:
  "(P \<longrightarrow>\<^sub>r Q \<or> R) = (Q \<or> (P \<longrightarrow>\<^sub>r R))"
  by pred_auto

lemma rea_not_true [simp]: "(\<not>\<^sub>r true) = false"
  by pred_auto

lemma rea_not_demorgan1 [simp]:
  "(\<not>\<^sub>r (P \<and> Q)) = (\<not>\<^sub>r P \<or> \<not>\<^sub>r Q)"
  by pred_auto

lemma rea_not_demorgan2 [simp]:
  "(\<not>\<^sub>r (P \<or> Q)) = (\<not>\<^sub>r P \<and> \<not>\<^sub>r Q)"
  by pred_auto

lemma rea_not_or [rpred]:
  "P is R1 \<Longrightarrow> (P \<or> \<not>\<^sub>r P) = true\<^sub>r"
  by (pred_auto; blast)

lemma rea_not_and [simp]:
  "(P \<and> \<not>\<^sub>r P) = false"
  by pred_auto

lemma truer_bottom_rpred [rpred]: "P is RR \<Longrightarrow> R1(true) \<sqsubseteq> P"
  by (simp add: RR_implies_R1 pred_ba.sup.order_iff rea_true_disj(1))

lemma ext_close_weakening: "P ;; true\<^sub>r \<sqsubseteq> P"
  by pred_auto

lemma rea_not_INFIMUM [simp]:
  "(\<not>\<^sub>r (\<Squnion>i\<in>A. Q(i))) = (\<Sqinter>i\<in>A. \<not>\<^sub>r Q(i))"
  by pred_auto

(* Why is this a separate law? *)
lemma rea_not_USUP [simp]:
  "(\<not>\<^sub>r (\<Squnion>i\<in>A. Q(i))) = (\<Sqinter>i\<in>A. \<not>\<^sub>r Q(i))"
  by simp

lemma rea_not_SUPREMUM [simp]:
  "A \<noteq> {} \<Longrightarrow> (\<not>\<^sub>r (\<Sqinter>i\<in>A. Q(i))) = (\<Squnion>i\<in>A. \<not>\<^sub>r Q(i))"
  by pred_auto

(* Why is this a separate law? *)
lemma rea_not_UINF [simp]:
  "A \<noteq> {} \<Longrightarrow> (\<not>\<^sub>r (\<Sqinter>i\<in>A. Q(i))) = (\<Squnion>i\<in>A. \<not>\<^sub>r Q(i))"
  by pred_auto

lemma USUP_mem_rea_true [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion> i \<in> A. true\<^sub>r) = true\<^sub>r"
  by pred_auto

lemma USUP_ind_rea_true [simp]: "(\<Squnion> i. true\<^sub>r) = true\<^sub>r"
  by pred_auto

lemma UINF_ind_rea_true [rpred]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter> i\<in>A. true\<^sub>r) = true\<^sub>r"
  by pred_auto

lemma UINF_rea_impl: "(\<Sqinter> P\<in>A. F(P) \<longrightarrow>\<^sub>r G(P)) = ((\<Squnion> P\<in>A. F(P)) \<longrightarrow>\<^sub>r (\<Sqinter> P\<in>A. G(P)))"
  by pred_auto

(*
lemma rea_not_shEx [rpred]: "(\<not>\<^sub>r shEx P) = (shAll (\<lambda> x. \<not>\<^sub>r P x))"
  by pred_auto
*)

lemma rea_assert_true:
  "{true\<^sub>r}\<^sub>r = II\<^sub>r"
  by pred_auto

lemma rea_false_true:
  "{false}\<^sub>r = true\<^sub>r"
  by pred_auto

lemma rea_rename_id [rpred]:
  assumes "P is RR"
  shows "P\<lparr>id\<rparr>\<^sub>r = P"
proof -
  have "(RR P)\<lparr>id\<rparr>\<^sub>r = RR P"
    by pred_auto
  thus ?thesis by (simp add: Healthy_if assms)
qed

(* twright: This was also oopsed in UTP1
lemma rea_rename_comp [rpred]:
  assumes "renamer f" "renamer g" "P is RR"
  shows "P\<lparr>g \<circ> f\<rparr>\<^sub>r = P\<lparr>g\<rparr>\<^sub>r\<lparr>f\<rparr>\<^sub>r"
  oops
*)

lemma rea_rename_false [rpred]: "false\<lparr>f\<rparr>\<^sub>r = false"
  by pred_auto

lemma rea_rename_disj [rpred]:
  "(P \<or> Q)\<lparr>f\<rparr>\<^sub>r = (P\<lparr>f\<rparr>\<^sub>r \<or> Q\<lparr>f\<rparr>\<^sub>r)"
  by (pred_auto; blast)

lemma rea_rename_UINF_ind [rpred]:
  "(\<Sqinter> i. P i)\<lparr>g\<rparr>\<^sub>r = (\<Sqinter> i. (P i)\<lparr>g\<rparr>\<^sub>r)"
  by (pred_auto; blast)

lemma rea_rename_UINF_mem [rpred]:
  "(\<Sqinter> i\<in>A. P i)\<lparr>g\<rparr>\<^sub>r = (\<Sqinter> i\<in>A. (P i)\<lparr>g\<rparr>\<^sub>r)"
  by (pred_auto; blast)

lemma rea_rename_conj [rpred]:
  assumes "renamer g" "P is RR" "Q is RR"
  shows "(P \<and> Q)\<lparr>g\<rparr>\<^sub>r = (P\<lparr>g\<rparr>\<^sub>r \<and> Q\<lparr>g\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer g by (simp add: assms)
  have "(RR P \<and> RR Q)\<lparr>g\<rparr>\<^sub>r = ((RR P)\<lparr>g\<rparr>\<^sub>r \<and> (RR Q)\<lparr>g\<rparr>\<^sub>r)"
    using injD[OF ren.injective]
    by (pred_auto; blast)
  thus ?thesis by (simp add: Healthy_if assms)
qed

lemma rea_rename_USUP_ind [rpred]:
  assumes "renamer g" "\<And> i. P i is RR"
  shows "(\<Squnion> i. P i)\<lparr>g\<rparr>\<^sub>r = (\<Squnion> i. (P i)\<lparr>g\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer g by (simp add: assms)
  have "(\<Squnion> i. RR(P i))\<lparr>g\<rparr>\<^sub>r = (\<Squnion> i. (RR (P i))\<lparr>g\<rparr>\<^sub>r)"
    using injD[OF ren.injective]
    by (pred_auto, blast, metis (mono_tags, opaque_lifting))
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_rename_USUP_mem [rpred]:
  assumes "renamer g" "A \<noteq> {}" "\<And> i. i \<in> A \<Longrightarrow> P i is RR"
  shows "(\<Squnion> i\<in>A. P i)\<lparr>g\<rparr>\<^sub>r = (\<Squnion> i\<in>A. (P i)\<lparr>g\<rparr>\<^sub>r)"
proof -
  interpret ren: renamer g by (simp add: assms)
  have "(\<Squnion> i\<in>A. RR(P i))\<lparr>g\<rparr>\<^sub>r = (\<Squnion> i\<in>A. (RR (P i))\<lparr>g\<rparr>\<^sub>r)"
    using injD[OF ren.injective] assms(2)
    by (pred_auto, blast, metis (no_types, opaque_lifting))
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_rename_skip_rea [rpred]: "renamer f \<Longrightarrow> II\<^sub>r\<lparr>f\<rparr>\<^sub>r = II\<^sub>r"
  using minus_zero_eq by pred_auto

lemma rea_rename_seq [rpred]:
  assumes "renamer g" "P is RR" "Q is RR"
  shows "(P ;; Q)\<lparr>g\<rparr>\<^sub>r = P\<lparr>g\<rparr>\<^sub>r ;; Q\<lparr>g\<rparr>\<^sub>r"
proof -
  interpret ren: renamer g by (simp add: assms)
  from assms(1) have "(RR(P) ;; RR(Q))\<lparr>g\<rparr>\<^sub>r = (RR P)\<lparr>g\<rparr>\<^sub>r ;; (RR Q)\<lparr>g\<rparr>\<^sub>r"
    by (pred_auto)
       (metis (no_types, lifting) diff_add_cancel_left' le_add minus_assoc mono_def ren.minus ren.monotonic trace_class.add_diff_cancel_left trace_class.add_left_mono)+
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

declare R4_idem [rpred]
declare R4_false [rpred]
declare R4_conj [rpred]
declare R4_disj [rpred]

declare R4_R5 [rpred]
declare R5_R4 [rpred]

declare R5_conj [rpred]
declare R5_disj [rpred]

lemma R4_USUP [rpred]: "I \<noteq> {} \<Longrightarrow> R4(\<Squnion> i\<in>I. P(i)) = (\<Squnion> i\<in>I. R4(P(i)))"
  by pred_auto

lemma R5_USUP [rpred]: "I \<noteq> {} \<Longrightarrow> R5(\<Squnion> i\<in>I. P(i)) = (\<Squnion> i\<in>I. R5(P(i)))"
  by pred_auto

lemma R4_UINF [rpred]: "R4(\<Sqinter> i\<in>I. P(i)) = (\<Sqinter> i\<in>I. R4(P(i)))"
  by pred_auto

lemma R5_UINF [rpred]: "R5(\<Sqinter> i\<in>I. P(i)) = (\<Sqinter> i\<in>I. R5(P(i)))"
  by pred_auto

subsection \<open> UTP theory \<close>

(*
text \<open> We create a UTP theory of reactive relations which in particular provides Kleene star theorems \<close>

interpretation rrel_theory: utp_theory_kleene RR II\<^sub>r
  rewrites "P \<in> carrier rrel_theory.thy_order \<longleftrightarrow> P is RR"
  and "le rrel_theory.thy_order = (\<sqsubseteq>)"
  and "eq rrel_theory.thy_order = (=)"
  and rrel_top: "rrel_theory.utp_top = false"
  and rrel_bottom: "rrel_theory.utp_bottom = true\<^sub>r"
proof -
  interpret utp_theory_continuous RR
    by (unfold_locales, simp_all add: add: RR_idem RR_Continuous)
  show top:"utp_top = false"
    by (simp add: healthy_top, rel_auto)
  show bot:"utp_bottom = true\<^sub>r"
    by (simp add: healthy_bottom, rel_auto)
  show "utp_theory_kleene RR II\<^sub>r"
    by (unfold_locales, simp_all add: closure rpred top)
qed (simp_all)

abbreviation rea_star :: "_ \<Rightarrow> _"  ("_\<^sup>\<star>\<^sup>r" [999] 999) where
"P\<^sup>\<star>\<^sup>r \<equiv> rrel_theory.utp_star P"

text \<open> The supernova tactic explodes conjectures using the Kleene star laws and relational calculus \<close>

method supernova = ((safe intro!: rrel_theory.Star_inductr rrel_theory.Star_inductl, simp_all add: closure) ; rel_auto)[1]

subsection \<open> Instantaneous Reactive Relations \<close>

text \<open> Instantaneous Reactive Relations, where the trace stays the same. \<close>

abbreviation Instant :: "('t::trace, '\<alpha>) hrel_rp \<Rightarrow> ('t, '\<alpha>) hrel_rp" where
"Instant(P) \<equiv> tr:\<lbrakk>P\<rbrakk>"

lemma skip_rea_Instant [closure]: "II\<^sub>r is Instant"
  by (rel_auto)
*)

end


section \<open>Priority Bag Interface\<close>
theory IICF_Prio_Bag
imports IICF_Multiset
begin
subsection \<open>Operations\<close>

  text \<open>We prove quite general parametricity lemmas, but restrict
    them to relations below identity when we register the operations.

    This restriction, although not strictly necessary, makes usage of the tool
    much simpler, as we do not need to handle different prio-functions for
    abstract and concrete types.
  \<close>

  context
    fixes prio:: "'a \<Rightarrow> 'b::linorder"
  begin
    definition "mop_prio_pop_min b = ASSERT (b\<noteq>{#}) \<then> SPEC (\<lambda>(v,b').
        v \<in># b
      \<and> b'=b - {#v#}
      \<and> (\<forall>v'\<in>set_mset b. prio v \<le> prio v'))"

    definition "mop_prio_peek_min b \<equiv> ASSERT (b\<noteq>{#}) \<then> SPEC (\<lambda>v.
          v \<in># b
        \<and> (\<forall>v'\<in>set_mset b. prio v \<le> prio v'))"

  end

  lemma param_mop_prio_pop_min[param]:
    assumes [param]: "(prio',prio) \<in> A \<rightarrow> B"
    assumes [param]: "((\<le>),(\<le>)) \<in> B \<rightarrow> B \<rightarrow> bool_rel"
    shows "(mop_prio_pop_min prio',mop_prio_pop_min prio) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A \<times>\<^sub>r \<langle>A\<rangle>mset_rel\<rangle>nres_rel"
    unfolding mop_prio_pop_min_def[abs_def]
    apply (clarsimp simp: mop_prio_pop_min_def nres_rel_def pw_le_iff refine_pw_simps)
    apply (safe; simp)
  proof goal_cases
    case (1 m n x)
    (*fix m n x*)
    assume "(m,n)\<in>\<langle>A\<rangle>mset_rel"
      and "x\<in>#m"
      and P': "\<forall>x'\<in>set_mset m. prio' x \<le> prio' x'"
    hence R: "rel_mset (rel2p A) m n" by (simp add: mset_rel_def p2rel_def)
    from multi_member_split[OF \<open>x\<in>#m\<close>] obtain m' where [simp]: "m=m'+{#x#}" by auto

    from msed_rel_invL[OF R[simplified]] obtain n' y where
      [simp]: "n=n'+{#y#}" and [param, simp]: "(x,y)\<in>A" and R': "(m',n')\<in>\<langle>A\<rangle>mset_rel"
      by (auto simp: rel2p_def mset_rel_def p2rel_def)
    have "\<forall>y'\<in>set_mset n. prio y \<le> prio y'"
    proof
      fix y' assume "y'\<in>set_mset n"
      then obtain x' where [param]: "(x',y')\<in>A" and "x'\<in>set_mset m"
        using R
        by (metis insert_DiffM msed_rel_invR rel2pD union_single_eq_member)
      with P' have "prio' x \<le> prio' x'" by blast
      moreover have "(prio' x \<le> prio' x', prio y \<le> prio y') \<in> bool_rel"
        by parametricity
      ultimately show "prio y \<le> prio y'" by simp
    qed
    thus
      "\<exists>a. (x, a) \<in> A \<and> (m - {#x#}, n - {#a#}) \<in> \<langle>A\<rangle>mset_rel \<and> a \<in># n \<and> (\<forall>v'\<in>set_mset n. prio a \<le> prio v')"
      using R' by (auto intro!: exI[where x=n'] exI[where x=y])
  qed

  lemma param_mop_prio_peek_min[param]:
    assumes [param]: "(prio',prio) \<in> A \<rightarrow> B"
    assumes [param]: "((\<le>),(\<le>)) \<in> B \<rightarrow> B \<rightarrow> bool_rel"
    shows "(mop_prio_peek_min prio',mop_prio_peek_min prio) \<in> \<langle>A\<rangle>mset_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
    unfolding mop_prio_peek_min_def[abs_def]
    apply (clarsimp
      simp: mop_prio_pop_min_def nres_rel_def pw_le_iff refine_pw_simps
      )
    apply (safe; simp?)
  proof -
    fix m n x
    assume "(m,n)\<in>\<langle>A\<rangle>mset_rel"
      and "x\<in>#m"
      and P': "\<forall>x'\<in>set_mset m. prio' x \<le> prio' x'"
    hence R: "rel_mset (rel2p A) m n" by (simp add: mset_rel_def p2rel_def)
    from multi_member_split[OF \<open>x\<in>#m\<close>] obtain m' where [simp]: "m=m'+{#x#}" by auto

    from msed_rel_invL[OF R[simplified]] obtain n' y where
      [simp]: "n=n'+{#y#}" and [param, simp]: "(x,y)\<in>A" and R': "(m',n')\<in>\<langle>A\<rangle>mset_rel"
      by (auto simp: rel2p_def mset_rel_def p2rel_def)

    have "\<forall>y'\<in>set_mset n. prio y \<le> prio y'"
    proof
      fix y' assume "y'\<in>set_mset n"
      then obtain x' where [param]: "(x',y')\<in>A" and "x'\<in>set_mset m"
        using R
        by (metis msed_rel_invR mset_contains_eq rel2pD union_mset_add_mset_left union_single_eq_member)
      with P' have "prio' x \<le> prio' x'" by blast
      moreover have "(prio' x \<le> prio' x', prio y \<le> prio y') \<in> bool_rel"
        by parametricity
      ultimately show "prio y \<le> prio y'" by simp
    qed
    thus "\<exists>y. (x, y) \<in> A \<and> y \<in># n \<and> (\<forall>v'\<in>set_mset n. prio y \<le> prio v')"
      using R' by (auto intro!: exI[where x=y])
  qed

  context fixes prio :: "'a \<Rightarrow> 'b::linorder" and A :: "('a\<times>'a) set" begin
    sepref_decl_op (no_def,no_mop) prio_pop_min:
      "PR_CONST (mop_prio_pop_min prio)" :: "\<langle>A\<rangle>mset_rel \<rightarrow>\<^sub>f \<langle>A \<times>\<^sub>r \<langle>A\<rangle>mset_rel\<rangle>nres_rel"
      where "IS_BELOW_ID A"
    proof goal_cases
      case 1
      hence [param]: "(prio,prio)\<in>A \<rightarrow> Id"
        by (auto simp: IS_BELOW_ID_def)
      show ?case
        apply (rule fref_ncI)
        apply parametricity
        by auto
    qed

    sepref_decl_op (no_def,no_mop) prio_peek_min:
      "PR_CONST (mop_prio_peek_min prio)" :: "\<langle>A\<rangle>mset_rel \<rightarrow>\<^sub>f \<langle>A\<rangle>nres_rel"
      where "IS_BELOW_ID A"
    proof goal_cases
      case 1
      hence [param]: "(prio,prio)\<in>A \<rightarrow> Id"
        by (auto simp: IS_BELOW_ID_def)
      show ?case
        apply (rule fref_ncI)
        apply parametricity
        by auto
    qed
  end

subsection \<open>Patterns\<close>

end


section \<open>Labels\<close>

theory Labels imports Com begin

text \<open>Labels describe a mapping from the inner node label
  to the matching command\<close>

inductive labels :: "cmd \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> bool"
where

Labels_Base:
  "labels c 0 c"

| Labels_LAss:
  "labels (V:=e) 1 Skip"

| Labels_Seq1:
  "labels c\<^sub>1 l c \<Longrightarrow> labels (c\<^sub>1;;c\<^sub>2) l (c;;c\<^sub>2)"

| Labels_Seq2:
  "labels c\<^sub>2 l c \<Longrightarrow> labels (c\<^sub>1;;c\<^sub>2) (l + #:c\<^sub>1) c"

| Labels_CondTrue:
  "labels c\<^sub>1 l c \<Longrightarrow> labels (if (b) c\<^sub>1 else c\<^sub>2) (l + 1) c"

| Labels_CondFalse:
  "labels c\<^sub>2 l c \<Longrightarrow> labels (if (b) c\<^sub>1 else c\<^sub>2) (l + #:c\<^sub>1 + 1) c"

| Labels_WhileBody:
  "labels c' l c \<Longrightarrow> labels (while(b) c') (l + 2) (c;;while(b) c')"

| Labels_WhileExit:
  "labels (while(b) c') 1 Skip"

| Labels_Call:
  "labels (Call p es rets) 1 Skip"

lemma label_less_num_inner_nodes:
  "labels c l c' \<Longrightarrow> l < #:c"
proof(induct c arbitrary:l c')
  case Skip
  from \<open>labels Skip l c'\<close> show ?case by(fastforce elim:labels.cases)
next
  case (LAss V e)
  from \<open>labels (V:=e) l c'\<close> show ?case by(fastforce elim:labels.cases)
next
  case (Seq c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l c'. labels c\<^sub>1 l c' \<Longrightarrow> l < #:c\<^sub>1\<close>
  note IH2 = \<open>\<And>l c'. labels c\<^sub>2 l c' \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>labels (c\<^sub>1;;c\<^sub>2) l c'\<close> IH1 IH2 show ?case
    by simp(erule labels.cases,auto,force)
next
  case (Cond b c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l c'. labels c\<^sub>1 l c' \<Longrightarrow> l < #:c\<^sub>1\<close>
  note IH2 = \<open>\<And>l c'. labels c\<^sub>2 l c' \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) l c'\<close> IH1 IH2 show ?case
    by simp(erule labels.cases,auto,force)
next
  case (While b c)
  note IH = \<open>\<And>l c'. labels c l c' \<Longrightarrow> l < #:c\<close>
  from \<open>labels (while (b) c) l c'\<close> IH show ?case
    by simp(erule labels.cases,fastforce+)
next
  case (Call p es rets)
  thus ?case by simp(erule labels.cases,fastforce+)
qed

declare One_nat_def [simp del]

lemma less_num_inner_nodes_label:
  assumes "l < #:c" obtains c' where "labels c l c'"
proof(atomize_elim)
  from \<open>l < #:c\<close> show "\<exists>c'. labels c l c'"
  proof(induct c arbitrary:l)
    case Skip
    from \<open>l < #:Skip\<close> have "l = 0" by simp
    thus ?case by(fastforce intro:Labels_Base)
  next
    case (LAss V e)
    from \<open>l < #:(V:=e)\<close> have "l = 0 \<or> l = 1" by auto
    thus ?case by(auto intro:Labels_Base Labels_LAss)
  next
    case (Seq c\<^sub>1 c\<^sub>2)
    note IH1 = \<open>\<And>l. l < #:c\<^sub>1 \<Longrightarrow> \<exists>c'. labels c\<^sub>1 l c'\<close>
    note IH2 = \<open>\<And>l. l < #:c\<^sub>2 \<Longrightarrow> \<exists>c'. labels c\<^sub>2 l c'\<close>
    show ?case
    proof(cases "l < #:c\<^sub>1")
      case True
      from IH1[OF this] obtain c' where "labels c\<^sub>1 l c'" by auto
      hence "labels (c\<^sub>1;;c\<^sub>2) l (c';;c\<^sub>2)" by(fastforce intro:Labels_Seq1)
      thus ?thesis by auto
    next
      case False
      hence "#:c\<^sub>1 \<le> l" by simp
      then obtain l' where "l = l' + #:c\<^sub>1" and "l' = l - #:c\<^sub>1" by simp
      from \<open>l = l' + #:c\<^sub>1\<close> \<open>l < #:c\<^sub>1;;c\<^sub>2\<close> have "l' < #:c\<^sub>2" by simp
      from IH2[OF this] obtain c' where "labels c\<^sub>2 l' c'" by auto
      with \<open>l = l' + #:c\<^sub>1\<close> have "labels (c\<^sub>1;;c\<^sub>2) l c'"
        by(fastforce intro:Labels_Seq2)
      thus ?thesis by auto
    qed
  next
    case (Cond b c\<^sub>1 c\<^sub>2)
    note IH1 = \<open>\<And>l. l < #:c\<^sub>1 \<Longrightarrow> \<exists>c'. labels c\<^sub>1 l c'\<close>
    note IH2 = \<open>\<And>l. l < #:c\<^sub>2 \<Longrightarrow> \<exists>c'. labels c\<^sub>2 l c'\<close>
    show ?case
    proof(cases "l = 0")
      case True
      thus ?thesis by(fastforce intro:Labels_Base)
    next
      case False
      hence "0 < l" by simp
      then obtain l' where "l = l' + 1" and "l' = l - 1" by simp
      thus ?thesis
      proof(cases "l' < #:c\<^sub>1")
        case True
        from IH1[OF this] obtain c' where "labels c\<^sub>1 l' c'" by auto
        with \<open>l = l' + 1\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c'"
          by(fastforce dest:Labels_CondTrue)
        thus ?thesis by auto
      next
        case False
        hence "#:c\<^sub>1 \<le> l'" by simp
        then obtain l'' where "l' = l'' + #:c\<^sub>1" and "l'' = l' - #:c\<^sub>1" by simp
        from \<open>l' = l'' + #:c\<^sub>1\<close> \<open>l = l' + 1\<close> \<open>l < #:if (b) c\<^sub>1 else c\<^sub>2\<close>
        have "l'' < #:c\<^sub>2" by simp
        from IH2[OF this] obtain c' where "labels c\<^sub>2 l'' c'" by auto
        with \<open>l' = l'' + #:c\<^sub>1\<close> \<open>l = l' + 1\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c'"
          by(fastforce dest:Labels_CondFalse)
        thus ?thesis by auto
      qed
    qed
  next
    case (While b c')
    note IH = \<open>\<And>l. l < #:c' \<Longrightarrow> \<exists>c''. labels c' l c''\<close>
    show ?case
    proof(cases "l < 1")
      case True
      hence "l = 0" by simp
      thus ?thesis by(fastforce intro:Labels_Base)
    next
      case False
      show ?thesis
      proof(cases "l < 2")
        case True
        with \<open>\<not> l < 1\<close> have "l = 1" by simp
        thus ?thesis by(fastforce intro:Labels_WhileExit)
      next
        case False
        with \<open>\<not> l < 1\<close> have "2 \<le> l" by simp
        then obtain l' where "l = l' + 2" and "l' = l - 2"
          by(simp del:add_2_eq_Suc')
        from \<open>l = l' + 2\<close> \<open>l < #:while (b) c'\<close> have "l' < #:c'" by simp
        from IH[OF this] obtain c'' where "labels c' l' c''" by auto
        with \<open>l = l' + 2\<close> have "labels (while (b) c') l (c'';;while (b) c')"
          by(fastforce dest:Labels_WhileBody)
        thus ?thesis by auto
      qed
    qed
  next
    case (Call p es rets)
    show ?case
    proof(cases "l < 1")
      case True
      hence "l = 0" by simp
      thus ?thesis by(fastforce intro:Labels_Base)
    next
      case False
      with \<open>l < #:Call p es rets\<close> have "l = 1" by simp
      thus ?thesis by(fastforce intro:Labels_Call)
    qed
  qed
qed

lemma labels_det:
  "labels c l c'\<Longrightarrow> (\<And>c''. labels c l c''\<Longrightarrow> c' = c'')"
proof(induct rule:labels.induct)
  case (Labels_Base c c'')
  from \<open>labels c 0 c''\<close> obtain l where "labels c l c''" and "l = 0" by auto
  thus ?case by(induct rule:labels.induct,auto)
next
  case (Labels_Seq1 c\<^sub>1 l c c\<^sub>2)
  note IH = \<open>\<And>c''. labels c\<^sub>1 l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels c\<^sub>1 l c\<close> have "l < #:c\<^sub>1" by(fastforce intro:label_less_num_inner_nodes)
  with \<open>labels (c\<^sub>1;;c\<^sub>2) l c''\<close> obtain cx where "c'' = cx;;c\<^sub>2 \<and> labels c\<^sub>1 l cx"
    by(fastforce elim:labels.cases intro:Labels_Base)
  hence [simp]:"c'' = cx;;c\<^sub>2" and "labels c\<^sub>1 l cx" by simp_all
  from IH[OF \<open>labels c\<^sub>1 l cx\<close>] show ?case by simp
next
  case (Labels_Seq2 c\<^sub>2 l c c\<^sub>1)
  note IH = \<open>\<And>c''. labels c\<^sub>2 l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels (c\<^sub>1;;c\<^sub>2) (l + #:c\<^sub>1) c''\<close> \<open>labels c\<^sub>2 l c\<close> have "labels c\<^sub>2 l c''"
    by(auto elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_CondTrue c\<^sub>1 l c b c\<^sub>2)
  note IH = \<open>\<And>c''. labels c\<^sub>1 l c'' \<Longrightarrow>  c = c''\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) (l + 1) c''\<close> \<open>labels c\<^sub>1 l c\<close> have "labels c\<^sub>1 l c''"
    by(fastforce elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_CondFalse c\<^sub>2 l c b c\<^sub>1)
  note IH = \<open>\<And>c''. labels c\<^sub>2 l c'' \<Longrightarrow>  c = c''\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) (l + #:c\<^sub>1 + 1) c''\<close> \<open>labels c\<^sub>2 l c\<close>
  have "labels c\<^sub>2 l c''"
    by(fastforce elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_WhileBody c' l c b)
  note IH = \<open>\<And>c''. labels c' l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels (while (b) c') (l + 2) c''\<close> \<open>labels c' l c\<close>
  obtain cx where "c'' = cx;;while (b) c' \<and> labels c' l cx"
    by -(erule labels.cases,auto)
  hence [simp]:"c'' = cx;;while (b) c'" and "labels c' l cx" by simp_all
  from IH[OF \<open>labels c' l cx\<close>] show ?case by simp
qed (fastforce elim:labels.cases)+

definition label :: "cmd \<Rightarrow> nat \<Rightarrow> cmd"
  where "label c n \<equiv> (THE c'. labels c n c')"

lemma labels_THE:
  "labels c l c' \<Longrightarrow> (THE c'. labels c l c') = c'"
by(fastforce intro:the_equality dest:labels_det)

lemma labels_label:"labels c l c' \<Longrightarrow> label c l = c'"
by(fastforce intro:labels_THE simp:label_def)

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
\<^marker>\<open>contributor "Peter Lammich"\<close>
section \<open>Additional Lemmas for NREST\<close>
theory NREST_Misc
  imports
 "HOL-Library.Extended_Nat" "Refine_Monadic.RefineG_Domain"  Refine_Monadic.Refine_Misc
  "HOL-Library.Monad_Syntax"   "HOL-Library.Groups_Big_Fun"
  Complex_Main
 "../cost/Abstract_Cost"
begin

paragraph \<open>Summary\<close>
text \<open>This theory contains auxiliary lemmas needed for the theory in NREST.\<close>

declare [[coercion_enabled = false]]

subsection "Auxiliaries for option"

lemma less_eq_option_None_is_None': "x \<le> None \<longleftrightarrow> x = None" by(auto simp: less_eq_option_None_is_None)

lemma everywhereNone: "(\<forall>x\<in>X. x = None) \<longleftrightarrow> X = {} \<or> X = {None}"
  by auto

lemma my_these_def: "Option.these M = {f. Some f \<in> M}"
  unfolding  Option.these_def by (auto intro: rev_image_eqI)

lemma option_Some_image:
    "A \<noteq> {} \<Longrightarrow> A \<noteq> {None} \<Longrightarrow> case_option None (Some \<circ> f) ` A \<noteq> {None}"
  by (metis (mono_tags, hide_lams) comp_apply empty_iff everywhereNone
                  imageI in_these_eq option.exhaust option.simps(5) these_insert_None)

lemma Option_these_case_option_eq_image: "Option.these (case_option None (\<lambda>e. Some (f e)) ` A)
        = f `(Option.these A)"
  unfolding Option.these_def apply (auto split: option.splits)
   apply force
  using image_iff by fastforce

subsection "Auxiliaries for enat"

abbreviation (input) "SUPREMUM S f \<equiv> Sup (f ` S)"

lemma helper: "x2 \<le> x2a \<Longrightarrow> \<not> x2 < a \<Longrightarrow> \<not> x2a < a \<Longrightarrow>  x2 - (a::enat) \<le> x2a - a"
  apply(cases x2; cases x2a) apply auto apply(cases a) by auto

lemma helper2: "x2b \<le> x2 \<Longrightarrow> \<not> x2a < x2  \<Longrightarrow> \<not> x2a < x2b \<Longrightarrow> x2a - (x2::enat) \<le> x2a - x2b"
  apply(cases x2; cases x2a) apply auto apply(cases x2b) by auto

lemma Sup_finite_enat: "Sup X = Some (enat a) \<Longrightarrow> Some (enat a) \<in> X"
  by (auto simp: Sup_option_def Sup_enat_def these_empty_eq Max_eq_iff in_these_eq split: if_splits)

lemma Sup_enat_less2: " Sup X = \<infinity> \<Longrightarrow> (\<exists>x\<in>X. enat t < x)"
  unfolding  Sup_enat_def using    finite_enat_bounded linear
  apply(auto split: if_splits)
   apply (smt Max_in empty_iff enat_ord_code(4))
  by (smt not_less)

lemma le_Some_infinity_enat[simp]: "t \<le> Some (\<infinity>::enat)"
  by (cases t, auto)

lemma Sup_image_emult1_aux1: "n\<noteq>0 \<Longrightarrow> xa * enat n = y * enat n \<Longrightarrow> xa = y"
  apply(cases xa; cases y) by auto

lemma mult_Max_commute:
  fixes k :: enat
  assumes "finite N" and "N \<noteq> {}"
  shows "k * Max N = Max {k * m | m. m \<in> N}"
proof -
  have "\<And>x y. k * max x y = max (k * x) (k * y)"
    apply (simp add: max_def not_le)
    apply(cases k) apply auto
    subgoal
      by (metis distrib_left leD le_iff_add)
    subgoal
      using \<open>\<And>y x nat. \<lbrakk>k = enat nat; x \<le> y; enat nat * y < enat nat * x\<rbrakk> \<Longrightarrow> enat nat * y = enat nat * x\<close> le_less by blast
    subgoal
      by (simp add: leD mult_left_mono)
    subgoal
      by (metis antisym enat_ord_code(3) imult_is_infinity not_le zero_le)
    done
  with assms show ?thesis
    using hom_Max_commute [of "times k" N]
    by simp (blast intro: arg_cong [where f = Max])
qed

lemma image_is_singleton_iff: "f`X={y} \<longleftrightarrow> (X\<noteq>{} \<and> (\<forall>x\<in>X. f x = y))" by auto

(* inspired by Sup_image_eadd1 *)
lemma Sup_image_emult1:
  assumes "Y \<noteq> {}"
  shows "Sup ((\<lambda>y :: enat. x * y) ` Y) = x * Sup Y"
proof(cases "finite Y")
  case True
  have "(*) x ` Y = {x * m |m. m \<in> Y}" by auto
  thus ?thesis using True by(simp add: Sup_enat_def mult_Max_commute assms)
next
  case False
  thus ?thesis
  proof(cases x)
    case (enat x')
    show ?thesis
      proof (cases "x'=0")
        case True
        then show ?thesis using enat apply (auto simp add: zero_enat_def[symmetric] )
          by (metis SUP_bot bot_enat_def)
      next
        case f: False
        with enat have "\<not> finite ((*) x ` Y)" using False
            apply(auto dest!: finite_imageD intro!: inj_onI)
            by (simp add: mult.commute Sup_image_emult1_aux1)
        with False f enat show ?thesis by(simp add: Sup_enat_def assms)
      qed
  next
    case infinity
    from False have i: "Sup Y \<noteq> 0"
      by (simp add: Sup_enat_def assms)
    from infinity False have "(*) x ` Y = {\<infinity>} \<or> (*) x ` Y = {\<infinity>,0}" using assms
      by (smt image_is_singleton_iff finite.simps image_insert imult_is_infinity insert_commute mk_disjoint_insert mult_zero_right)
    thus ?thesis using i infinity assms
      apply auto
      subgoal by (metis imult_is_infinity)
      subgoal
        by (metis Sup_enat_def ccSup_empty imult_is_infinity sup_bot.right_neutral)
      done
  qed
qed

lemma enat_mult_cont: "Sup A * (c::enat) = Sup ((\<lambda>x. x*c)`A)"
  apply(cases "A={}")
  subgoal unfolding Sup_enat_def by simp
  using Sup_image_emult1
  by (metis mult_commute_abs)

lemma enat_mult_cont':
  fixes f :: "'a \<Rightarrow> enat"
  shows
  "(Sup (f ` A)) * c = Sup ((\<lambda>x. f x * c) ` A)"
  using enat_mult_cont[of "f`A" c]
  by (metis (mono_tags, lifting) SUP_cong   image_image)

lemma enat_add_cont':
  fixes f g :: "'a \<Rightarrow> enat"
  shows "(SUP b\<in>B. f b) + (SUP b\<in>B. g b) \<ge> (SUP b\<in>B. f b + g b)"
  by (auto intro: Sup_least add_mono Sup_upper)

lemma enat_Sum_any_cont:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> enat"
  assumes f: "finite {x. \<exists>y. f x y \<noteq> 0}"
  shows
  "SUPREMUM B (\<lambda>y. Sum_any (\<lambda>x. f x y)) \<le> Sum_any (\<lambda>x. (SUPREMUM B (f x)))"
proof -
  have "{a. SUPREMUM B (f a) \<noteq> 0} \<subseteq> {x. \<exists>y. f x y \<noteq> 0}"
    apply auto by (metis SUP_eqI i0_lb le_zero_eq)

  { fix S :: "'a set"
    assume "finite S"
    then have "(SUP y\<in>B. \<Sum>x\<in>S. f x y) \<le> (\<Sum>x\<in>S. SUPREMUM B (f x))"
    proof (induct rule: finite_induct)
      case empty
      then show ?case apply auto
      by (metis SUP_bot_conv(2) bot_enat_def)
    next
      case (insert a A)
      have "(SUP y\<in>B. (\<Sum>x\<in>insert a A. f x y)) =  (SUP y\<in>B. f a y + (\<Sum>x\<in>A. f x y))"
        using sum.insert insert by auto
      also have "\<dots> \<le> (SUP b\<in>B. f a b) + (SUP y\<in>B. \<Sum>x\<in>A. f x y)"
        apply(subst enat_add_cont') by simp
      also have "\<dots> \<le> (SUP b\<in>B. f a b) + (\<Sum>x\<in>A. SUP b\<in>B. f x b)" using insert by auto
      also have "\<dots> = (\<Sum>x\<in>insert a A. SUP a\<in>B. f x a)"
        using sum.insert insert by auto
      finally show ?case .
    qed
  } note finite_SUP_sum = this

  thm Sum_any.expand_set
  show ?thesis
    apply(subst (1) Sum_any.expand_superset[of "{x. \<exists>y. f x y \<noteq> 0}"])
    subgoal by fact subgoal apply auto done
    apply(subst (1) Sum_any.expand_superset[of "{x. \<exists>y. f x y \<noteq> 0}"])
    subgoal by fact subgoal apply fact done
    using f by(rule finite_SUP_sum)
qed

lemma enat_plus_Sup_distrib:
  "A\<noteq>{} \<Longrightarrow> (a::enat) + Sup A = Sup ((+) a ` A)"
  apply(cases a)
  subgoal
  unfolding Sup_enat_def apply auto
   apply (metis Max.hom_commute empty_iff enat_add_left_cancel_le max_def plus_enat_simps(2))
  apply(subst (asm) finite_image_iff)
  subgoal unfolding inj_on_def by auto
  subgoal apply simp done
  done
  subgoal by simp
  done

lemma ecost_plus_Sup_distrib:
  "A\<noteq>{} \<Longrightarrow> (a::(_,enat) acost) + Sup A = Sup ((+) a ` A)"
  unfolding Sup_acost_def apply(cases a)
  unfolding plus_acost_alt apply simp
  apply(rule ext)
proof (goal_cases)
  case (1 x xa)
  have "x xa + (SUP f\<in>A. the_acost f xa) = x xa + (SUP f\<in>the_acost `A. f xa)"
    apply simp  by (metis SUP_apply Sup_apply)
  also have "\<dots> = x xa + (SUP v\<in>{f xa|f. f \<in> the_acost `A}. v)"
    by (simp add: setcompr_eq_image)
  also have "\<dots> = Sup ((+) (x xa) ` {f xa|f. f \<in> the_acost `A})"
    apply(subst enat_plus_Sup_distrib) using 1(1) by auto
  also have "\<dots> = (SUP x\<in>case_acost (\<lambda>b. acostC (\<lambda>xa. x xa + b xa)) ` A. the_acost x xa) "
    apply(rule arg_cong[where f=Sup])
    apply auto
    subgoal for xb apply(cases xb) apply (auto simp: )
      apply(rule image_eqI) by auto
    subgoal for xb apply(cases xb) apply (auto simp: )
      apply(rule image_eqI) apply(rule refl) apply auto
      by force
    done
  finally show ?case .
qed

lemma map_option_case_option_conv: "map_option f = case_option None (\<lambda>x. Some (f x))"
  apply (rule ext)
  unfolding map_option_case by simp

lemma map_option_plus_ecost_continuous:
  fixes t :: "(_,enat) acost"
  shows "(\<lambda>a. map_option ((+) t) a) (Sup A) = Sup ((\<lambda>a. map_option ((+) (t)) a) ` A)"
  unfolding map_option_case_option_conv
  unfolding Sup_option_def[unfolded my_these_def]
  apply (simp add: option_Some_image  )
  apply rule+
  subgoal
    by (metis empty_is_image Option_these_case_option_eq_image these_empty_eq)
  subgoal apply(subst ecost_plus_Sup_distrib)
    subgoal
        using everywhereNone by fastforce
  apply(rule arg_cong[where f=Sup])
    by  (auto split: option.splits  intro: rev_image_eqI)
  done

lemma map_option_plus_enat_continuous:
  fixes t :: enat
  shows "(\<lambda>a. map_option ((+) t) a) (Sup A) = Sup ((\<lambda>a. map_option ((+) (t)) a) ` A)"
  unfolding map_option_case_option_conv
  unfolding Sup_option_def[unfolded my_these_def]
  apply (simp add: option_Some_image  )
  apply rule+
  subgoal
    by (metis empty_is_image Option_these_case_option_eq_image these_empty_eq)
  subgoal apply(subst enat_plus_Sup_distrib)
    subgoal
        using everywhereNone by fastforce
  apply(rule arg_cong[where f=Sup])
    by  (auto split: option.splits  intro: rev_image_eqI)
  done

lemma conc_fun_consume_aux:
  fixes x2 :: "_ \<Rightarrow> (_,enat) acost option"
  shows "Sup ((\<lambda>a. map_option ((+) t) a) ` {x2 a| a. (c, a) \<in> R})
         = (\<lambda>a. map_option ((+) t) a) (Sup {x2 a |a. (c, a) \<in> R})"
  apply(subst map_option_plus_ecost_continuous)
  apply simp done

subsection "Auxiliary (for Sup and Inf)"

lemma aux2: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1} = {None} \<longleftrightarrow> (M x = None \<and> M\<noteq>Map.empty)"
  apply (cases "M x"; auto simp: image_is_singleton_iff)
  by force

lemma aux3: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1} = {Some t1 | t1. M x = Some t1} \<union> ({None | y. y\<noteq>x \<and> M y \<noteq> None })"
  by (fastforce split: if_splits simp: image_iff)

lemma Sup_pointwise_eq_fun: "(SUP f\<in>{[x \<mapsto> t1] |x t1. M x = Some t1}. f x) = M x"
  unfolding Sup_option_def
  apply (simp add: aux2)
  apply (auto simp: aux3)
  by (metis (mono_tags, lifting) Some_image_these_eq Sup_least in_these_eq mem_Collect_eq sup_absorb1 these_image_Some_eq)

lemma SUP_eq_None_iff: "(SUP f\<in>X. f x) = None \<longleftrightarrow> X={} \<or> (\<forall>f\<in>X. f x = None)"
  by (smt SUP_bot_conv(2) SUP_empty Sup_empty empty_Sup)

lemma SUP_eq_Some_iff: "(SUP f\<in>X. f x) = Some t \<longleftrightarrow> (\<exists>f\<in>X. f x \<noteq> None) \<and> (t=Sup {t' | f t'. f\<in>X \<and> f x = Some t' })"
  apply auto
  subgoal
    by (smt Sup_bot_conv(1) Sup_empty Sup_option_def Sup_pointwise_eq_fun imageE option.distinct(1))
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits; safe)
    subgoal by (force simp: image_iff)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  done

lemma Sup_enat_less: "X \<noteq> {} \<Longrightarrow> enat t \<le> Sup X \<longleftrightarrow> (\<exists>x\<in>X. enat t \<le> x)"
  apply rule
  subgoal
  by (metis Max_in Sup_enat_def finite_enat_bounded linear)
  subgoal apply auto
    by (simp add: Sup_upper2)
  done

(*
  This is how implication can be phrased with an Inf operation.
  Generalization from boolean to enat can be explained this way.
 *)

lemma fixes Q P  shows
    "Inf { P x \<le> Q x |x. True}  \<longleftrightarrow> P \<le> Q" unfolding le_fun_def by simp

subsection \<open>continuous\<close>
term sup_continuous

text \<open>That might by Scott continuity;

     https://en.wikipedia.org/wiki/Scott_continuity \<close>

text \<open>There is scott_continuous in Complete_Non_Orders.Fixed_Points\<close>

definition continuous :: "('a::{Sup} \<Rightarrow> 'b::{Sup}) \<Rightarrow> bool"  where
  "continuous f \<longleftrightarrow> (\<forall>A. Sup (f ` A) = f (Sup A) )"

definition continuousInf :: "('a::{Inf} \<Rightarrow> 'b::{Inf}) \<Rightarrow> bool"  where
  "continuousInf f \<longleftrightarrow> (\<forall>A. A\<noteq>{} \<longrightarrow> Inf (f ` A) = f (Inf A) )"

term sup_continuous
thm continuous_at_Sup_mono

lemma "continuous (f::'a::{complete_lattice}\<Rightarrow>'b::{complete_lattice})
         \<longleftrightarrow> (\<forall>A. Inf (f ` A) = f (Inf A) )" (* wrong conjecture *) oops

lemma continuousI: "(\<And>A. f (Sup A) = Sup (f ` A)) \<Longrightarrow> continuous f" by (auto simp: continuous_def)
lemma continuousD: "continuous f \<Longrightarrow> f (Sup A) = Sup (f ` A)" by (auto simp: continuous_def)

lemma continuousInfI: "(\<And>A. A\<noteq>{} \<Longrightarrow> f (Inf A) = Inf (f ` A)) \<Longrightarrow> continuousInf f" by (auto simp: continuousInf_def)
lemma continuousInfD: "continuousInf f \<Longrightarrow> A\<noteq>{} \<Longrightarrow> f (Inf A) = Inf (f ` A)" by (auto simp: continuousInf_def)

lemma continuous_Domain: "continuous Domain"
  apply(rule continuousI) by (fact Domain_Union)

lemma continuous_Range: "continuous Range"
  apply(rule continuousI) by (fact Range_Union)

subsubsection \<open>combinations are continuous\<close>

lemma continuousInf_funs:
  assumes *: "\<And>x. continuousInf (\<lambda>s. f s x)"
  shows "continuousInf (\<lambda>s. f (s x) (m x))"
  apply(rule continuousInfI)
  unfolding Inf_fun_def
  apply(subst continuousInfD[OF *]) apply simp
  apply(subst image_image) by simp

lemma continuousInf_Map_empty: "continuousInf Map.empty"
  apply(rule continuousInfI)
  by simp

lemma continuous_app: "continuous (\<lambda>f. f x)"
  apply(rule continuousI)
  by simp

lemma
  continuous_fun:
  assumes *: "continuous f" shows "continuous  (\<lambda>X x. (f (X x)))"
  apply(rule continuousI)
  unfolding Sup_fun_def  apply(rule ext)
  apply(subst continuousD[OF *]) apply(subst image_image) apply(subst image_image) ..

lemma
  continuousInf_fun:
  assumes *: "continuousInf f" shows "continuousInf  (\<lambda>X x. (f (X x)))"
  apply(rule continuousInfI)
  unfolding Inf_fun_def  apply(rule ext)
  apply(subst continuousInfD[OF *]) subgoal apply simp done
    apply(subst image_image) apply(subst image_image) ..

lemma SupD: "Sup A = Some f \<Longrightarrow> A \<noteq> {} \<and> A\<noteq>{None}"
  unfolding Sup_option_def by auto

lemma zzz: "Option.these A \<noteq> {}
 \<Longrightarrow> Sup ( (\<lambda>x. case x of None \<Rightarrow> None | Some e \<Rightarrow> Some (f e)) ` A)
        = Some (Sup ( f ` Option.these A))"
  apply(subst Sup_option_def)
  apply simp
  apply safe
  subgoal
    by simp
  subgoal
    by (metis SupD image_is_singleton_iff empty_Sup in_these_eq option.simps(5))
  subgoal apply(subst Option_these_case_option_eq_image) by simp
  done

lemma assumes "continuous f"
  shows "continuous (case_option None (Some o f))" (* TODO: generalize to adding top/bottom element *)
  apply(rule continuousI)
  apply(auto split: option.splits)
  subgoal unfolding Sup_option_def by (auto split: if_splits)
proof -
  fix A   and a :: "'a::{complete_lattice}"
  assume a: "Sup A = Some a"
  with SupD have A: "A \<noteq> {} \<and> A \<noteq> {None}" by auto

  then have a': "a= Sup (Option.these A)"
    by (metis Sup_option_def a option.inject)

  from A have oA: "Option.these A \<noteq> {}" unfolding Option.these_def by auto

  have *: "\<And>x. Some (f x) = (Some o f) x" by simp
  have "(SUP x\<in>A. case x of None \<Rightarrow> None | Some x \<Rightarrow> (Some \<circ> f) x)
        = (SUP x\<in>A. case x of None \<Rightarrow> None | Some s \<Rightarrow> Some (f s))"
    by(simp only: *)
  also have "\<dots> = Some (SUP s\<in>(Option.these A). (f s))"
   using oA zzz by metis

  also have "(SUP s\<in>(Option.these A). (f s)) = f a"
    using a' assms(1)[THEN continuousD] by metis

  finally show "Some (f a) = (SUP x\<in>A. case x of None \<Rightarrow> None | Some x \<Rightarrow> (Some \<circ> f) x)"  by simp
qed

text \<open>a shorter proof\<close>

lemma continuous_option: (* or generally, adding a bottom element *)
  assumes *: "continuous f"
  shows "continuous (case_option None (Some o f))"
  apply(rule continuousI)
  unfolding Sup_option_def[unfolded my_these_def]
  apply (simp add: option_Some_image)
  apply (simp add:  continuousD[OF *])
  apply rule+
  apply(rule arg_cong[where f=Sup])
    by  (auto split: option.splits  intro: rev_image_eqI)

lemma continuous_option':
  assumes *: "continuous f"
  shows "continuous (case_option None (\<lambda>x. Some (f x)))"
  using continuous_option[OF *, unfolded comp_def]  .

lemma continuousInf_option: (* or generally, adding a bottom element *)
  assumes *: "continuousInf f"
  shows "continuousInf (case_option None (\<lambda>x. Some (f x)))"
  apply(rule continuousInfI)
  unfolding Inf_option_def[unfolded my_these_def]
  apply (simp add: option_Some_image )
  apply safe
  subgoal by force
  subgoal by(auto split: option.splits)
  subgoal apply(subst continuousInfD[OF *]) subgoal
    by (metis Collect_empty_eq Inf_lower \<open>\<And>A. Inf A = (if None \<in> A then None else Some (Inf {f. Some f \<in> A}))\<close> le_some_optE)
    apply(rule arg_cong[where f=Inf])
    by  (auto split: option.splits  intro: rev_image_eqI)
  done

lemma continuous_map_option: "continuous f \<Longrightarrow> continuous (map_option f)"
  unfolding map_option_case_option_conv apply(intro continuous_option') .

definition myminus where "myminus x y = (if x=\<infinity> \<and> y=\<infinity> then 0 else x - y)"
lemma "(a::enat) + x \<ge> b  \<longleftrightarrow> x \<ge> myminus b a "
  unfolding myminus_def
  apply(cases a; cases b; cases x) apply auto oops

end


(*by Lammich*)
theory Time_Reasoning
imports "../Separation_Logic_Imperative_HOL/Sep_Main"
begin

  text \<open>Separating correctness and time reasoning for imperative HOL.
    In this theory, we provide a method to add time-reasoning to
    an already proved-correct program.

    The time-reasoning can exploit knowledge from the correctness proof via assertions.
  \<close>

subsection \<open>Selectors\<close>
  text \<open>We define selectors into the result of a state-time-monad computation\<close>

  definition "fails m h \<equiv> execute m h = None"
  definition "the_res m h \<equiv> case execute m h of Some (r,_,_) \<Rightarrow> r"
  definition "the_heap m h \<equiv> case execute m h of Some (_,h',_) \<Rightarrow> h'"

  text \<open>We define the time to be zero for a failing computation,
    such that failing computations trivially satisfy time bounds.

    Note that the computation is already proved non-failing by the correctness proof,
    this allows us to assume computations do not fail for the time-bound proof.
  \<close>
  definition "time c h \<equiv> case execute c h of None \<Rightarrow> 0 | Some (_,_,t) \<Rightarrow> t"

  lemma time_refines: "refines c c' \<Longrightarrow> \<not>fails c' h \<Longrightarrow> time c h \<le> time c' h"
    unfolding time_def refines_def fails_def
    apply (auto split: option.splits)
    done

  lemma fails_refines: "refines c c' \<Longrightarrow> fails c h \<Longrightarrow> fails c' h"
    unfolding time_def refines_def fails_def
    apply (auto split: option.splits)
    by (metis option.exhaust prod_cases3)

subsubsection \<open>Simplification Lemmas\<close>

  named_theorems fails_simp
  named_theorems time_simp

  lemma fails_return[fails_simp]: "\<not>fails (return x) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_wait[fails_simp]: "\<not>fails (wait x) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_assert'[fails_simp]: "fails (assert' P) h \<longleftrightarrow> \<not>P"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_bind[fails_simp]: "fails (bind m f) h \<longleftrightarrow> (\<not>fails m h \<longrightarrow> fails (f (the_res m h)) (the_heap m h))"
    unfolding fails_def the_res_def the_heap_def
    apply (auto simp add: execute_simps split: option.split)
    using timeFrame.elims by auto

  lemma fails_array_nth[fails_simp]: "fails (Array_Time.nth p i) h \<longleftrightarrow> \<not>(i < Array_Time.length h p)"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_upd[fails_simp]: "fails (Array_Time.upd i x p) h \<longleftrightarrow> \<not>(i < Array_Time.length h p)"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_len[fails_simp]: "\<not>fails (Array_Time.len p) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_new[fails_simp]: "\<not>fails (Array_Time.new n x) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_of_list[fails_simp]: "\<not>fails (Array_Time.of_list xs) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_make[fails_simp]: "\<not>fails (Array_Time.make n f) h"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_map_entry[fails_simp]: "fails (Array_Time.map_entry i x p) h \<longleftrightarrow> \<not>(i < Array_Time.length h p)"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma fails_array_swap[fails_simp]: "fails (Array_Time.swap i x p) h \<longleftrightarrow> \<not>(i < Array_Time.length h p)"
    unfolding fails_def by (auto simp add: execute_simps split: option.split)

  lemma time_return[time_simp]: "time (return x) h = 1"
    unfolding time_def by (simp add: execute_simps)

  lemma time_bind[time_simp]: "time (bind m f) h = (
    if \<not>fails m h \<and> \<not>fails (f (the_res m h)) (the_heap m h) then time m h + time (f (the_res m h)) (the_heap m h)
    else 0
  )"
    unfolding time_def the_res_def fails_def the_heap_def
    by (auto simp add: execute_simps split: option.split)

  lemma time_wait[time_simp]: "time (wait n) h = n"
    unfolding time_def by (simp add: execute_simps)

  lemma time_raise[time_simp]: "time (raise msg) h = 0"
    by (auto simp: time_def execute_simps)

  lemma time_assert'[time_simp]: "time (assert' P) h = 0"
    unfolding time_def
    by (auto simp add: execute_simps split: option.split)

  lemma time_array_nth[time_simp]: "time (Array_Time.nth p i) h = (if fails (Array_Time.nth p i) h then 0 else 1)"
    unfolding time_def by (auto simp add: execute_simps fails_simp split: option.split)

  lemma time_array_upd[time_simp]: "time (Array_Time.upd i x p) h = (if fails (Array_Time.upd i x p) h then 0 else 1)"
    unfolding time_def by (auto simp add: execute_simps fails_simp split: option.split)

  lemma time_array_len[time_simp]: "time (Array_Time.len p) h = 1"
    unfolding time_def by (auto simp add: execute_simps fails_simp split: option.split)

  lemma time_array_new[time_simp]: "time (Array_Time.new n x) h = n+1"
    unfolding time_def
    by (auto simp add: execute_simps fails_simp split: option.split prod.splits)

  lemma time_array_of_list[time_simp]: "time (Array_Time.of_list xs) h = length xs+1"
    unfolding time_def
    by (auto simp add: execute_simps fails_simp split: option.split prod.splits)

  lemma time_array_make[time_simp]: "time (Array_Time.make n f) h = n+1"
    unfolding time_def
    by (auto simp add: execute_simps fails_simp split: option.split prod.splits)

  lemma time_array_map_entry[time_simp]: "time (Array_Time.map_entry i f p) h = (if fails (Array_Time.map_entry i f p) h then 0 else 2)"
    unfolding time_def by (auto simp add: execute_simps fails_simp split: option.split)

  lemma time_array_swap[time_simp]: "time (Array_Time.swap i x p) h = (if fails (Array_Time.map_entry i f p) h then 0 else 2)"
    unfolding time_def by (auto simp add: execute_simps fails_simp split: option.split)

  lemma time_array_freeze[time_simp]: "time (Array_Time.freeze p) h = Array_Time.length h p+1"
    unfolding time_def
    by (auto simp add: execute_simps fails_simp split: option.split prod.splits)

subsection \<open>Hoare Triple with Time\<close>

  definition htt::"assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> nat\<Rightarrow> bool"("<_>/ _/ <_> T/[_]") where
  "htt P c Q t \<equiv> <P> c <Q> \<and> (\<forall>h as. (h,as) \<Turnstile> P \<longrightarrow> time c h \<le> t)"

  lemma httI[intro?]:
    assumes "<P> c <Q>"
    assumes "\<And>h as. (h,as) \<Turnstile> P \<Longrightarrow> time c h \<le> t"
    shows "< P> c <Q>T[t]"
    using assms unfolding htt_def by auto

  lemma htt_refine:
    assumes "< P> c <Q>T[ t]"
    assumes "refines c' c"
    shows " <P> c' <Q>T[ t]"
    by (smt (verit, best) assms(1) assms(2) dual_order.trans fails_def
      hoare_tripleE hoare_triple_refines htt_def option.simps(3) time_refines)

  lemma htt_cons_rule:
    assumes  "<P'> c <Q'>T[t']"
      " P \<Longrightarrow>\<^sub>A P'"
      "\<And> x. Q' x \<Longrightarrow>\<^sub>A Q x" "t' \<le> t"
    shows "<P>c <\<lambda> x. Q x >T[t]"
    using assms cons_rule[OF assms(2,3)] unfolding htt_def
    using entails_def by fastforce

  lemma norm_pre_ex_rule_htt:
  " (\<And>x. <P x> f <Q>T[t]) \<Longrightarrow> <\<exists>\<^sub>Ax. P x> f <Q>T[t]"
    by (metis htt_def mod_ex_dist norm_pre_ex_rule)

  lemma norm_post_ex_rule_htt:
  " ( <P> f <(Q x)>T[t]) \<Longrightarrow> <P> f <\<lambda> r. (\<exists>\<^sub>A x. Q x r)>T[t]"
   by (meson ent_refl eq_iff htt_cons_rule triv_exI)

  lemma norm_pre_pure_iff_htt:
  "<P * \<up> b> f <Q>T[t] = (b \<longrightarrow> <P> f <Q>T[t])"
    using htt_def by fastforce

  lemma norm_pre_pure_iff_htt':
  "< \<up> b*P > f <Q>T[t] = (b \<longrightarrow> <P> f <Q>T[t])"
  using htt_def by fastforce

subsection \<open>Proving time Bounds\<close>

  definition "TBOUND m t \<equiv> \<forall>h. time m h \<le> t"

  lemma TBOUNDI[intro?]: "\<lbrakk>\<And>h. time m h \<le> t\<rbrakk> \<Longrightarrow> TBOUND m t"
    by (auto simp: TBOUND_def)

  lemma TBOUNDD: "TBOUND m t \<Longrightarrow> time m h \<le> t"
    by (auto simp: TBOUND_def)

  lemma TBOUND_eqI:
    assumes "\<And>h. time m h = t"
    shows "TBOUND m t"
    apply rule
    using assms by simp

  lemma TBOUND_empty: "TBOUND (Heap.Heap Map.empty) t"
    unfolding TBOUND_def time_def by (simp)

  lemma TBOUND_mono: "TBOUND c t \<Longrightarrow> t\<le>t' \<Longrightarrow> TBOUND c t'"
    apply (auto simp: TBOUND_def)
    by (meson order.trans)

lemma TBOUND_refines: "TBOUND c t \<Longrightarrow> refines c d \<Longrightarrow> TBOUND d t"
  apply (auto simp: TBOUND_def refines_def time_def)
  apply(auto split: option.split)
  subgoal for h a aa b
  proof-
    assume 1: "\<forall>h. (case execute c h of None \<Rightarrow> 0 | Some (x, xa, t) \<Rightarrow> t) \<le> t"
    show "\<forall>h. case execute d h of None \<Rightarrow> True | Some (r, h', t) \<Rightarrow> execute c h = Some (r, h', t) \<Longrightarrow>
    execute d h = Some (a, aa, b) \<Longrightarrow> b \<le> t "
    proof-
      assume 2:"\<forall>h. case execute d h of None \<Rightarrow> True | Some (r, h', t) \<Rightarrow> execute c h = Some (r, h', t)"
      show "execute d h = Some (a, aa, b) \<Longrightarrow> b \<le> t "
      proof-
        assume "execute d h = Some (a, aa, b)"
        hence  "execute c h = Some (a, aa, b)" using 2
          by (smt (z3) old.prod.case option.simps(5))
        thus "b \<le> t" using 1
          by (metis old.prod.case option.simps(5))
      qed
    qed
  qed
  done

  text \<open>This rule splits a Hoare-triple with time into
    a Hoare-triple without time and a time-bound proof,
    thus separating the proof of correctness and time.
  \<close>
  lemma httI_TBOUND:
    assumes "<P> c <Q>"
    assumes "TBOUND c t"
    shows "< P> c <Q>T[t]"
    by (simp add: TBOUNDD assms(1) assms(2) httI)

  lemma htt_htD:
    assumes "<P> c <Q>T[t]"
    shows "<P> c <Q>"
    using assms htt_def by auto

  subsubsection \<open>Admissibility\<close>
  context begin
  private lemma TBOUND_adm_aux:
    "(\<lambda>f. \<forall>xx y. f xx = Some y \<longrightarrow> (case y of (_,_,tt) \<Rightarrow> tt \<le> t x))
     = (\<lambda>xa. \<forall>h. time (Heap.Heap xa) h \<le> t x)"
    apply (auto simp: fun_eq_iff time_def split: option.splits)
    done

  lemma TBOUND_adm: "heap.admissible (\<lambda>f. \<forall>x. TBOUND (f x) (t x))"
    unfolding TBOUND_def
    apply (rule admissible_fun[OF heap_interpretation])

    unfolding Heap_lub_def Heap_ord_def
    apply (rule admissible_image)
    subgoal
      by (simp add: flat_interpretation partial_function_lift)

    subgoal
      apply (simp add: comp_def)
      apply (fold TBOUND_adm_aux)
      using option_admissible .

     apply (metis Heap_execute)
    by simp
  end

  text \<open>Ad-hoc instances of admissible rule\<close>
  lemma TBOUND_fi_adm: "heap.admissible (\<lambda> fi'. \<forall>x xa. TBOUND (curry fi' x xa) (foo x xa))"
    apply (rule ccpo.admissibleI)
    apply clarsimp
    apply (rule ccpo.admissibleD[OF TBOUND_adm, rule_format, where t="\<lambda>(x,xa). foo x xa" and x="(x,xa)" for x xa, simplified])
    by auto

  lemma TBOUND_fi'_adm: "heap.admissible (\<lambda> fi'. \<forall>x xa xb. TBOUND (curry (curry fi') x xa xb) (foo x xa xb))"
    apply (rule ccpo.admissibleI)
    apply clarsimp
    apply (rule ccpo.admissibleD[OF TBOUND_adm, rule_format, where t="\<lambda>((x,xa),xb). foo x xa xb" and x="((x,xa),xb)" for x xa xb, simplified])
    by auto

  subsubsection \<open>Syntactic Rules for \<^const>\<open>TBOUND\<close>\<close>

  text \<open>Technical workaround:
    Tag to protect a schematic variable from the simplifier's solver.
    Used to simplify a term and then unify with schematic variable.

    A goal of the form \<open>EQ t ?t'\<close> can be simplified, and then resolved with rule \<open>EQ_refl\<close>.
    If one would run the simplifier on \<open>t = ?t'\<close>, the solver would apply @{thm refl} immediately,
    not simplifying \<open>t\<close>.
  \<close>
  definition "EQ a b \<equiv> a=b"
  lemma EQI: "a=b \<Longrightarrow> EQ a b" by (simp add: EQ_def)
  lemma EQD: "EQ a b \<Longrightarrow> a=b" by (simp add: EQ_def)
  lemma EQ_refl: "EQ a a" by (simp add: EQ_def)

  named_theorems TBOUND \<open>Syntactic rules for time-bounds\<close>

  lemma TBOUND_bind:
    assumes "TBOUND m t\<^sub>1"
    assumes "\<And>x h. \<lbrakk>x = the_res m h; \<not>fails m h\<rbrakk> \<Longrightarrow> TBOUND (f x) t\<^sub>2"
    shows "TBOUND (do {x\<leftarrow>m; f x}) (t\<^sub>1 + t\<^sub>2)"
    apply (rule)
    using assms[THEN TBOUNDD]
    apply (auto simp add: time_simp add_mono)
    done

  lemma TBOUND_assert'_bind:
    assumes "EQ P P'"
    assumes "P \<Longrightarrow> TBOUND m t"
    shows "TBOUND (do {assert' P; m}) (if P' then t else 0)"
    apply (rule)
    using assms(2)[THEN TBOUNDD] using assms(1)[THEN EQD]
    apply (auto simp add: time_simp add_mono fails_simp)
    done

  lemma TBOUND_assert'_weak[TBOUND]:
    assumes "P \<Longrightarrow> TBOUND m t"
    shows "TBOUND (do {assert' P; m}) t"
    apply (rule)
    using assms[THEN TBOUNDD]
    apply (auto simp add: time_simp add_mono fails_simp)
    done

  lemma TBOUND_bind_weak[TBOUND]:
    assumes "TBOUND m t\<^sub>1"
    assumes "\<And>x h. \<lbrakk>\<not>fails m h\<rbrakk> \<Longrightarrow> TBOUND (f x) t\<^sub>2"
    shows "TBOUND (do {x\<leftarrow>m; f x}) (t\<^sub>1 + t\<^sub>2)"
    apply (rule)
    using assms[THEN TBOUNDD]
    apply (auto simp add: time_simp add_mono)
    done

  lemma TBOUND_return[TBOUND]: "TBOUND (return x) 1"
    apply(rule TBOUND_eqI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_of_list[TBOUND]: "TBOUND (Array_Time.of_list xs) (Suc (length xs))"
     apply(rule TBOUND_eqI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_len[TBOUND]: "TBOUND (Array_Time.len xs) 1"
     apply(rule TBOUND_eqI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_nth[TBOUND]: "TBOUND (Array_Time.nth xs i) 1"
    apply(rule TBOUNDI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_upd[TBOUND]: "TBOUND (Array_Time.upd xs i x) 1"
    apply(rule TBOUNDI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_new[TBOUND]: "TBOUND (Array_Time.new n x) (n+1)"
    apply(rule TBOUNDI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_make[TBOUND]: "TBOUND (Array_Time.make n f) (n+1)"
    apply(rule TBOUNDI)
    apply(simp add: time_simp)
    done

  lemma TBOUND_swap[TBOUND]: "TBOUND (Array_Time.swap i x a) 2"
    apply(rule TBOUNDI)
    apply(subst time_simp)
    apply(simp)
    done

  lemma TBOUND_map_entry[TBOUND]: "TBOUND (Array_Time.map_entry i x a) 2"
    apply(rule TBOUNDI)
    apply(subst time_simp)
    apply(simp)
    done

  lemma TBOUND_cons: " TBOUND m t\<Longrightarrow> EQ t  t' \<Longrightarrow> TBOUND m t'"
    unfolding EQ_def
    by simp

  lemma TBOUND_if_max[TBOUND]:
    assumes "P \<Longrightarrow> TBOUND m bm"
    assumes "\<not> P \<Longrightarrow> TBOUND n bn"
    shows "TBOUND (if P then m else n) (max bm bn)"
    using assms
    apply( auto simp add: TBOUND_def max_def)
     apply (meson TBOUNDD TBOUND_mono assms)
    apply (meson dual_order.trans nat_le_linear)
    done

  lemma TBOUND_if_strong:
    assumes "EQ b b'"
      assumes "b \<Longrightarrow> TBOUND m\<^sub>1 t\<^sub>1"
      assumes "\<not>b \<Longrightarrow> TBOUND m\<^sub>2 t\<^sub>2"
      shows "TBOUND (if b then m\<^sub>1 else m\<^sub>2) (if b' then t\<^sub>1  else t\<^sub>2)"
    using assms unfolding EQ_def by auto

  lemma TBOUND_if:
    assumes "b \<Longrightarrow> TBOUND m\<^sub>1 t\<^sub>1"
    assumes "\<not>b \<Longrightarrow> TBOUND m\<^sub>2 t\<^sub>2"
    shows "TBOUND (if b then m\<^sub>1 else m\<^sub>2) (if b then t\<^sub>1 else t\<^sub>2)"
    using assms by auto

  lemma TBOUND_Let:
    assumes "\<And>x. x = v \<Longrightarrow> TBOUND (f x) (t x)"
    shows "TBOUND (let x=v in f x) (let x=v in t x)"
    using assms by auto

  lemma TBOUND_Let_strong:
    assumes "EQ v v'"
    assumes "\<And> x. x = v \<Longrightarrow> TBOUND (f x) (bnd x)"
    shows " TBOUND (let x = v in f x) (let x = v' in bnd x)"
    using assms unfolding EQ_def by simp

  lemma TBOUND_Let_weak[TBOUND]:
    assumes "\<And> x. x = v \<Longrightarrow> TBOUND (f x) (bnd )"
    shows " TBOUND (let x = v in f x) bnd "
    using assms by simp

  lemma TBOUND_option_case[TBOUND]:
    assumes "t = None \<Longrightarrow> TBOUND f bnd"
     "\<And> x. t = Some x \<Longrightarrow> TBOUND (f' x) (bnd' x)"
    shows "TBOUND (case t of None \<Rightarrow> f | Some x \<Rightarrow> f' x)
                (case t of None \<Rightarrow> bnd | Some x \<Rightarrow> bnd' x)"
    using assms
    apply(cases t)
     apply auto
    done

  lemma TBOUND_prod_case[TBOUND]:
    assumes "\<And> a b. t = (a, b) \<Longrightarrow> TBOUND (f a b) (bnd a b)"
    shows "TBOUND (case t of (a, b) \<Rightarrow> f a b) (case t of (a, b) \<Rightarrow> bnd a b) "
    using assms apply(cases t)
    by auto

 lemma TBOUND_assert'_bind_strong:
    assumes "P \<Longrightarrow> TBOUND m t"
    shows "TBOUND (do {assert' P; m}) (if P then t else 0)"
    apply (rule)
    using assms[THEN TBOUNDD]
    apply (auto simp add: time_simp add_mono fails_simp)
    done

subsubsection \<open>Automation\<close>

  named_theorems TBOUND_simps

  lemmas [TBOUND_simps] = if_cancel Let_const

  method TBOUND_simp_EQ = ( rule EQI; (elim conjE )? ;simp only: TBOUND_simps ; fail)

  method TBOUND_step_strong = (rule  TBOUND_assert'_bind TBOUND_Let_strong TBOUND_if_strong, TBOUND_simp_EQ)

 method TBOUND_gen_step methods fallback =
    (TBOUND_step_strong |
     rule TBOUND |
     assumption|
     rule TBOUND_cons, (rule TBOUND| assumption) |
     TBOUND_simp_EQ |
     fallback)

  method TBOUND_step' = TBOUND_gen_step \<open>simp; fail\<close>
  method TBOUND_step = TBOUND_gen_step \<open>fail\<close>

 method defer_le = (rule asm_rl[of "_ \<le> _"], tactic \<open>defer_tac 1\<close>)

method TBOUND= (rule TBOUND_mono, ( TBOUND_step'+ ; fail), defer_le)

end