theory SLTC_More
imports SLTC
begin

subsection \<open>models rules\<close>

declare mod_ex_dist [simp]

lemma mod_star_trueI: "h\<Turnstile>P \<Longrightarrow> h\<Turnstile>P*true"
  by (metis assn_times_comm entailsD' entails_true mult.left_neutral)

lemma mod_false[simp]: "\<not> h\<Turnstile>false"
  by (simp add: pure_assn_rule)

lemmas mod_pure_star_dist[simp] = mod_pure_star_dist

lemma mod_pure_star_dist'[simp]: "h\<Turnstile>\<up>b*P \<longleftrightarrow> h\<Turnstile>P \<and> b"
  using mod_pure_star_dist
  by (simp add: mult.commute)

lemma mod_starD: "h\<Turnstile>A*B \<Longrightarrow> \<exists>h1 h2. h1\<Turnstile>A \<and> h2\<Turnstile>B"
  by (metis assn_ext mod_star_convE)

subsection \<open>entailment rules\<close>

lemmas ent_true[simp] = entails_true

declare entails_triv [simp]

lemma inst_ex_assn: "A \<Longrightarrow>\<^sub>A B x \<Longrightarrow> A \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. B x)"
  using entails_ex_post by blast

lemma ent_iffI:
  assumes "A\<Longrightarrow>\<^sub>AB"
  assumes "B\<Longrightarrow>\<^sub>AA"
  shows "A=B"
  apply(rule assn_ext)
  using assms
  using entails_def by blast

lemma ent_star_mono: "\<lbrakk> P \<Longrightarrow>\<^sub>A P'; Q \<Longrightarrow>\<^sub>A Q'\<rbrakk> \<Longrightarrow> P*Q \<Longrightarrow>\<^sub>A P'*Q'"
  using  entails_trans2 entails_frame  by blast

lemma merge_true_star_ctx: "true * (true * P) = true * P"
  by (metis assn_times_assoc top_assn_reduce)

lemma ent_true_drop:
  "P\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R\<Longrightarrow>\<^sub>AQ*true"
  "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>AQ*true"
  apply (metis assn_times_comm ent_star_mono ent_true merge_true_star_ctx)
  apply (metis assn_one_left ent_star_mono ent_true mult.commute)
  done

lemma ent_true_drop_fst:
  "R\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R\<Longrightarrow>\<^sub>AQ*true"
  apply (metis assn_times_comm ent_star_mono ent_true merge_true_star_ctx)
  done

lemma ent_true_drop_fstf:
  "R\<Longrightarrow>\<^sub>Atrue*Q \<Longrightarrow> P*R\<Longrightarrow>\<^sub>Atrue*Q"
  apply (metis ent_star_mono ent_true merge_true_star_ctx)
  done

lemma ent_ex_preI: "(\<And>x. P x \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> \<exists>\<^sub>Ax. P x \<Longrightarrow>\<^sub>A Q"
  by (meson entails_ex)

lemma ent_ex_postI: "Q \<Longrightarrow>\<^sub>A P x \<Longrightarrow> Q \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. P x "
  using entails_ex_post by blast

lemma entailsI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> h\<Turnstile>Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
  using assms unfolding entails_def by auto

lemma ent_trans[trans]: "\<lbrakk> P \<Longrightarrow>\<^sub>A Q; Q \<Longrightarrow>\<^sub>AR \<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>A R"
  by (auto intro: entailsI dest: entailsD)

lemma ent_frame_fwd:
  assumes R: "P \<Longrightarrow>\<^sub>A R"
  assumes F: "Ps \<Longrightarrow>\<^sub>A P*F"
  assumes I: "R*F \<Longrightarrow>\<^sub>A Q"
  shows "Ps \<Longrightarrow>\<^sub>A Q"
  using assms
  by (metis entails_triv ent_star_mono ent_trans)

lemma ent_pure_pre_iff[simp]: "(P*\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto   )

lemma ent_pure_pre_iff_sng[simp]:
  "(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A Q))"
  using ent_pure_pre_iff[where P=emp]
  by simp

lemma ent_pure_post_iff[simp]:
  "(P \<Longrightarrow>\<^sub>A Q*\<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto)

lemma ent_pure_post_iff_sng[simp]:
  "(P \<Longrightarrow>\<^sub>A \<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A emp))"
  using ent_pure_post_iff[where Q=emp]
  by simp

lemma ent_false: "false \<Longrightarrow>\<^sub>A P" by simp

lemma ex_assn_cases: "(Q x \<Longrightarrow>\<^sub>A P) \<or> \<not> (\<exists>\<^sub>A y. Q y \<Longrightarrow>\<^sub>A P)"
  using entails_ex by blast

lemma fr_refl': "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> C * A \<Longrightarrow>\<^sub>A C * B"
  by (blast intro: ent_star_mono entails_triv)

subsection \<open>assertion normalization rules\<close>

lemmas [simp] = zero_time

lemmas merge_true_star[simp] = top_assn_reduce

lemma false_absorb[simp]: "false * R = false"
  by (simp add: assn_ext mod_false')

lemma star_false_right[simp]: "P * false = false"
  using false_absorb by (simp add: assn_times_comm)

lemma pure_true[simp]: "\<up>True = emp"
  by (auto intro: assn_ext simp: one_assn_rule pure_assn_rule)

lemma pure_assn_eq_conv[simp]: "\<up>P = \<up>Q \<longleftrightarrow> P=Q"
  by (metis (full_types) assn_times_comm empty_iff in_range.simps mod_false' mod_pure_star_dist top_assn_rule)

lemma ex_distrib_star': "Q * (\<exists>\<^sub>Ax. P x ) = (\<exists>\<^sub>Ax. Q * P x)"
proof -
  have "Q * (\<exists>\<^sub>Ax. P x ) = (\<exists>\<^sub>Ax. P x ) * Q"
    by (simp add: assn_times_comm)
  also have "\<dots> = (\<exists>\<^sub>Ax. P x * Q )"
    unfolding ex_distrib_star by simp
  also have "\<dots> = (\<exists>\<^sub>Ax. Q * P x )"
    by (simp add: assn_times_comm)
  finally show ?thesis .
qed

lemma ex_false_iff_false[simp]: "(\<exists>\<^sub>A x. false) = false" by (simp add: ent_ex_preI ent_iffI)

subsection "for relH"

text "Transitivity"
lemma relH_trans[trans]: "\<lbrakk>relH as h1 h2; relH as h2 h3\<rbrakk> \<Longrightarrow> relH as h1 h3"
  unfolding relH_def
  by auto

lemma in_range_subset:
  "\<lbrakk>as \<subseteq> as'; in_range (h,as')\<rbrakk> \<Longrightarrow> in_range (h,as)"
  by auto

lemma relH_subset:
  assumes "relH bs h h'"
  assumes "as \<subseteq> bs"
  shows "relH as h h'"
  using assms unfolding relH_def by (auto intro: in_range_subset)

subsection "new_addrs"

lemma new_addrs_id[simp]: "(new_addrs h as h) = as" unfolding new_addrs_def by auto

subsection "entailst"

definition entailst :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>t" 10)
  where "entailst A B \<equiv> A \<Longrightarrow>\<^sub>A B * true"
lemma enttI: "A\<Longrightarrow>\<^sub>AB*true \<Longrightarrow> A\<Longrightarrow>\<^sub>tB" unfolding entailst_def .
lemma enttD: "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB*true" unfolding entailst_def .

lemma entt_refl': "P\<Longrightarrow>\<^sub>A P * true"
  by (simp add: entailsI mod_star_trueI)

lemma entt_fr_drop: "F\<Longrightarrow>\<^sub>tF' \<Longrightarrow> F*A \<Longrightarrow>\<^sub>t F'"
  using ent_true_drop(1) enttD enttI by blast

lemma entt_trans:
  "entailst A B \<Longrightarrow> entailst B C \<Longrightarrow> entailst A C"
  unfolding entailst_def
  apply (erule ent_trans)
  by (metis assn_times_assoc ent_star_mono ent_true merge_true_star)

lemma ent_imp_entt: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>tQ"
  apply (rule enttI)
  apply (erule ent_trans)
  by (simp add: entailsI mod_star_trueI)

lemma entt_refl[simp, intro!]: "P\<Longrightarrow>\<^sub>t P "
  by (simp add: entailst_def entailsI mod_star_trueI)

lemma entt_star_mono: "\<lbrakk>entailst A B; entailst C D\<rbrakk> \<Longrightarrow> entailst (A*C) (B*D)"
  unfolding entailst_def
proof -
  assume a1: "A \<Longrightarrow>\<^sub>A B * true"
  assume "C \<Longrightarrow>\<^sub>A D * true"
  then have "A * C \<Longrightarrow>\<^sub>A true * B * (true * D)"
    using a1 assn_times_comm ent_star_mono by force
  then show "A * C \<Longrightarrow>\<^sub>A B * D * true"
    by (simp add: ab_semigroup_mult_class.mult.left_commute assn_times_comm)
qed

lemma entt_emp[simp, intro!]:
  "entailst A emp"
  unfolding entailst_def by simp

lemma entt_star_true_simp[simp]:
  "entailst A (B*true) \<longleftrightarrow> entailst A B"
  "entailst (A*true) B \<longleftrightarrow> entailst A B"
  unfolding entailst_def
  subgoal by (auto simp: assn_times_assoc)
  subgoal
    apply (intro iffI)
    subgoal using entails_def mod_star_trueI by blast
    subgoal by (metis assn_times_assoc entails_triv ent_star_mono merge_true_star)
    done
  done

lemma entt_def_true: "(P\<Longrightarrow>\<^sub>tQ) \<equiv> (P*true \<Longrightarrow>\<^sub>A Q*true)"
  unfolding entailst_def
  apply (rule eq_reflection)
  using entailst_def entt_star_true_simp(2) by auto

lemma entt_frame_fwd:
  assumes "entailst P Q"
  assumes "entailst A (P*F)"
  assumes "entailst (Q*F) B"
  shows "entailst A B"
  using assms
  by (metis entt_refl entt_star_mono entt_trans)

subsection "Heap Or"

declare or_assn_conv [simp]

lemma ex_distrib_or: "(\<exists>\<^sub>Ax. Q x) \<or>\<^sub>A P = (\<exists>\<^sub>Ax. Q x \<or>\<^sub>A P)"
  by (auto intro!: assn_ext simp: mod_ex_dist)

lemma sup_commute: "P \<or>\<^sub>A Q = Q \<or>\<^sub>A P"
  by (meson assn_ext or_assn_conv)

lemma ent_disjI1:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI2:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "Q \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entailsI)

lemma ent_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entailsI)

lemma entt_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI1_direct])

lemma entt_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI2_direct])

lemma entt_disjI1': "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  using entt_disjI1_direct entt_trans by blast

lemma entt_disjI2': "A\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  using entt_disjI2_direct entt_trans by blast

lemma ent_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>AC; B\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>AC"
  by (simp add: entails_def)

lemma entt_disjD1: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tC"
  using entt_disjI1_direct entt_trans by blast

lemma entt_disjD2: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> B\<Longrightarrow>\<^sub>tC"
  using entt_disjI2_direct entt_trans by blast

lemma star_or_dist1:
  "(A \<or>\<^sub>A B)*C = (A*C \<or>\<^sub>A B*C)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (fastforce simp: mod_star_conv )+

lemma star_or_dist2:
  "C*(A \<or>\<^sub>A B) = (C*A \<or>\<^sub>A C*B)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (fastforce simp: mod_star_conv )+

lemmas star_or_dist = star_or_dist1 star_or_dist2

lemma ent_disjI1': "A\<Longrightarrow>\<^sub>AB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma ent_disjI2': "A\<Longrightarrow>\<^sub>AC \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma merge_pure_or[simp]:
  "\<up>a \<or>\<^sub>A \<up>b = \<up>(a\<or>b)"
  by(auto intro!: assn_ext simp add: and_assn_conv pure_assn_rule)

lemma or_assn_false[simp]:
  "R \<or>\<^sub>A false = R"
  "false \<or>\<^sub>A R = R"
  by (simp_all add: ent_disjE ent_iffI)

subsection \<open>New command ureturn\<close>

definition ureturn :: "'a \<Rightarrow> 'a Heap" where
  [code del]: "ureturn x = Heap_Time_Monad.heap (\<lambda>h. (x,h,0))"

lemma execute_ureturn [execute_simps]:
  "execute (ureturn x) = Some \<circ> (\<lambda>h. (x,h,0))"
  by (simp add: ureturn_def execute_simps)

lemma success_ureturnI [success_intros]:
  "success (ureturn x) h"
  by (rule successI) (simp add: execute_simps)

lemma effect_ureturnI [effect_intros]:
  "h = h' \<Longrightarrow> effect (ureturn x) h h' x 0"
  by (rule effectI) (simp add: execute_simps)

lemma effect_ureturnE [effect_elims]:
  assumes "effect (ureturn x) h h' r n"
  obtains "r = x" "h' = h" "n=0"
  using assms by (rule effectE) (simp add: execute_simps)

lemma ureturn_bind [simp]: "ureturn x \<bind> f =   f x"
  apply (rule Heap_eqI)
  by (auto simp add: execute_simps )

lemma bind_ureturn [simp]: "f \<bind> ureturn =   f"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma execute_ureturn' [rewrite]: "execute (ureturn x) h = Some (x, h, 0)" by (metis comp_eq_dest_lhs execute_ureturn)

lemma run_ureturnD: "run (ureturn x) (Some h) \<sigma> r t \<Longrightarrow> \<sigma> = Some h \<and> r = x \<and> t = 0"
  by (auto simp add: execute_ureturn' run.simps)

lemma return_rule:
  "<$0> ureturn x <\<lambda>r. \<up>(r = x)>"
  unfolding hoare_triple_def by (auto dest!: run_ureturnD simp: relH_def timeCredit_assn_rule)

subsection "Heap And"

lemma mod_and_dist: "h\<Turnstile>P\<and>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<and> h\<Turnstile>Q"
  by (rule and_assn_conv)

lemma [simp]: "false\<and>\<^sub>AQ = false"
  apply(rule assn_ext)
  by(simp add: mod_and_dist)
lemma [simp]: "Q\<and>\<^sub>Afalse = false"
  apply(rule assn_ext)
  by(simp add: mod_and_dist)

lemma ent_conjI: "\<lbrakk> A\<Longrightarrow>\<^sub>AB; A\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<and>\<^sub>A C"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma ent_conjE1: "\<lbrakk>A\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)
lemma ent_conjE2: "\<lbrakk>B\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma true_conj: "true \<and>\<^sub>A P = P"
  using ent_conjE2 ent_conjI ent_iffI by auto

lemma hand_commute[simp]: "A \<and>\<^sub>A B = B \<and>\<^sub>A A"
using ent_conjE1 ent_conjE2 ent_conjI ent_iffI by auto

lemma and_extract_pure_left_iff[simp]: "\<up>b \<and>\<^sub>A Q = (emp\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_left_ctx_iff[simp]: "P*\<up>b \<and>\<^sub>A Q = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_right_iff[simp]: "P \<and>\<^sub>A \<up>b = (emp\<and>\<^sub>AP)*\<up>b"
  by (cases b) (auto simp: hand_commute)

lemma and_extract_pure_right_ctx_iff[simp]: "P \<and>\<^sub>A Q*\<up>b = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma [simp]: "(x \<and>\<^sub>A y) \<and>\<^sub>A z = x \<and>\<^sub>A y \<and>\<^sub>A z"
  using assn_ext and_assn_conv by presburger

lemma emp_and [simp]: "emp \<and>\<^sub>A emp = emp"
  unfolding and_assn_def
  apply (subst (3) one_assn_def)
  by (auto simp: one_assn_rule)

lemma pure_and: "\<up>P \<and>\<^sub>A \<up>Q = \<up>(P \<and> Q)"
  by (auto simp add: pure_conj)

lemma "h \<Turnstile> r \<mapsto>\<^sub>r x \<and>\<^sub>A r' \<mapsto>\<^sub>r y \<Longrightarrow> (r = r' \<and> x = y \<and> card (addrOf h) = 1)"
  by (cases h) (auto simp: and_assn_conv sngr_assn_rule)

subsection \<open>Precision\<close>
text \<open>
  Precision rules describe that parts of an assertion may depend only on the
  underlying heap. For example, the data where a pointer points to is the same
  for the same heap.
\<close>
text \<open>Precision rules should have the form:
  @{text [display] "\<forall>x y. (h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"}\<close>
definition "precise R \<equiv> \<forall>a a' h p F F'.
  h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<longrightarrow> a = a'"

lemma preciseI[intro?]:
  assumes "\<And>a a' h p F F'. h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<Longrightarrow> a = a'"
  shows "precise R"
  using assms unfolding precise_def by blast

lemma preciseD:
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F'"
  shows "a=a'"
  using assms unfolding precise_def by blast

lemma preciseD':
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F"
  assumes "h \<Turnstile> R a' p * F'"
  shows "a=a'"
  apply (rule preciseD)
  apply (rule assms)
  apply (simp only: mod_and_dist)
  apply (blast intro: assms)
  done

lemma precise_extr_pure[simp]:
  "precise (\<lambda>x y. \<up>P * R x y) \<longleftrightarrow> (P \<longrightarrow> precise R)"
  "precise (\<lambda>x y. R x y * \<up>P) \<longleftrightarrow> (P \<longrightarrow> precise R)"
   subgoal apply (cases P) by (auto intro!: preciseI)
   subgoal apply (cases P) by (auto intro!: preciseI simp: assn_times_comm and_assn_conv)
   done

lemma sngr_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>rx)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  subgoal for a a' h
    apply(cases h)
    by(auto dest!: mod_star_convE simp: sngr_assn_rule)
  done

lemma snga_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>ax)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  subgoal for a a' h
    apply(cases h)
    by(auto dest!: mod_star_convE simp: snga_assn_rule)
  done

text \<open>Apply precision rule with frame inference.\<close>
lemma prec_frame:
  assumes PREC: "precise P"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x p * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y p * F2"
  shows "x=y"
  using preciseD[OF PREC] M1 F1 F2
  by (meson mod_and_dist entailsD)

subsection \<open>is_pure_assn\<close>

definition "is_pure_assn a \<equiv> \<exists>P. a=\<up>P"
lemma is_pure_assnE: assumes "is_pure_assn a" obtains P where "a=\<up>P"
  using assms
  by (auto simp: is_pure_assn_def)

lemma is_pure_assn_pure[simp, intro!]: "is_pure_assn (\<up>P)"
  by (auto simp add: is_pure_assn_def)

lemma is_pure_assn_basic_simps[simp]:
  "is_pure_assn false"
  "is_pure_assn emp"
proof -
  have "is_pure_assn (\<up>False)" by rule thus "is_pure_assn false" by simp
  have "is_pure_assn (\<up>True)" by rule thus "is_pure_assn emp" by simp
qed

lemma is_pure_assn_starI[simp,intro!]:
  "\<lbrakk>is_pure_assn a; is_pure_assn b\<rbrakk> \<Longrightarrow> is_pure_assn (a*b)"
    by (auto simp: pure_conj[symmetric] elim!: is_pure_assnE)

subsection "some automation"

text \<open>Move existential quantifiers to the front of assertions\<close>
lemma ex_assn_move_out[simp]:
  "\<And>Q R. (\<exists>\<^sub>Ax. Q x) * R = (\<exists>\<^sub>Ax. (Q x * R))"
  "\<And>Q R. R * (\<exists>\<^sub>Ax. Q x) = (\<exists>\<^sub>Ax. (R * Q x))"

  "\<And>P Q. (\<exists>\<^sub>Ax. Q x) \<or>\<^sub>A P = (\<exists>\<^sub>Ax. (Q x \<or>\<^sub>A P))"
  "\<And>P Q. Q \<or>\<^sub>A (\<exists>\<^sub>Ax. P x) = (\<exists>\<^sub>Ax. (Q \<or>\<^sub>A P x))"
  apply -
  apply (simp add: ex_distrib_star)
  apply (subst mult.commute)
  apply (subst (2) mult.commute)
  apply (simp add: ex_distrib_star)

  apply (simp add: ex_distrib_or)
  apply (subst sup_commute)
  apply (subst (2) sup_commute)
  apply (simp add: ex_distrib_or)
  done

lemmas star_aci =
  mult.assoc[where 'a=assn] mult.commute[where 'a=assn] mult.left_commute[where 'a=assn]
  assn_one_left mult_1_right[where 'a=assn]
  merge_true_star merge_true_star_ctx

declare pure_assn_rule [simp]

subsection \<open>two references pointing to same address\<close>

text \<open>Two disjoint parts of the heap cannot be pointed to by the
  same pointer\<close>
lemma sngr_same_false_aux: "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y \<Longrightarrow>\<^sub>A false"
  unfolding entails_def
  apply clarify
  apply (case_tac h)
  apply clarify
  apply (drule mod_star_convE)
  apply (clarsimp simp add: sngr_assn_rule)
  done

lemma snga_same_false_aux: "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y \<Longrightarrow>\<^sub>A false"
  unfolding entails_def
  apply clarify
  apply (case_tac h)
  apply clarify
  apply (drule mod_star_convE)
  apply clarify
  apply (subst (asm) snga_assn_rule)
  apply (subst (asm) snga_assn_rule)
  apply clarify
  apply (clarsimp simp add: snga_assn_rule)
  done

lemma sngr_same_false[simp]:
  "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y = false"
by (intro sngr_same_false_aux ent_false ent_iffI)

lemma snga_same_false[simp]:
  "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y = false"
  by (intro snga_same_false_aux ent_false ent_iffI)

subsection \<open>Hoare consequence rules\<close>

lemmas fi_rule = pre_rule''

lemma cons_post_rule: "<P> c <Q> \<Longrightarrow> (\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x) \<Longrightarrow> <P> c <Q'>"
  using post_rule by blast

lemma cons_rule:
  assumes "<P> c <Q>" "P' \<Longrightarrow>\<^sub>A P" "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  shows "<P'> c <Q'>"
  using assms pre_rule cons_post_rule by blast

lemma cons_rulet:
  assumes T: "<P> c <Q>\<^sub>t" and PRE: "P' \<Longrightarrow>\<^sub>t P" and POST:"\<And>x. Q x \<Longrightarrow>\<^sub>t Q' x"
  shows "<P'> c <Q'>\<^sub>t"
proof -
  have "<P'> c <\<lambda>a. Q a * true>\<^sub>t"
    using PRE \<open><P> c <Q>\<^sub>t\<close> fi_rule entailst_def by blast
  then show ?thesis
    using POST by (meson entailst_def cons_post_rule ent_true_drop(1))
qed

end


theory Rely_Guarantee
  imports Language
begin

definition atomic :: "'a rel \<Rightarrow> ('a \<times> 'a) lan" ("\<langle>_\<rangle>" [0] 1000) where
  "\<langle>R\<rangle> \<equiv> ((\<lambda>x. LCons x LNil) ` R)"

lemma atomic_zero [simp]: "\<langle>{}\<rangle> = {}"
  by (auto simp add: atomic_def)

lemma [iff]: "\<langle>X\<rangle> = \<langle>Y\<rangle> \<longleftrightarrow> X = Y"
  by (auto simp add: atomic_def)

lemma atom_finite [intro!]: "\<langle>R\<rangle> \<subseteq> FIN"
  by (auto simp add: FIN_def atomic_def)

lemma [dest!]: "x \<in> lset (xs \<frown> ys) \<Longrightarrow> x \<in> lset xs \<or> x \<in> lset ys"
  by (metis in_lset_lappend_iff)

lemma rely_power1: "x \<in> power \<langle>R\<rangle> i \<Longrightarrow> lfinite x"
  by (induct i arbitrary: x) (auto simp add: l_prod_def atomic_def)

lemma rely_power2: "x \<in> power \<langle>R\<rangle> i \<Longrightarrow> (a, b) \<in> lset x \<Longrightarrow> (a, b) \<in> R"
proof (induct i arbitrary: x)
  case 0 thus ?case
    by simp
next
  case (Suc n) thus ?case
    apply simp
    apply (erule rev_mp)
    apply (subst fin_l_prod)
    by (auto simp add: atomic_def FIN_def)
qed

lemma lset_LCons_subsetD: "lset (LCons x xs) \<subseteq> R \<Longrightarrow> lset xs \<subseteq> R"
  by (metis Coinductive_List.lset_eq_lsetp Collect_mono dual_order.trans lsetp.intros(2))

lemma rely_power3: "lfinite xs \<Longrightarrow> lset xs \<subseteq> R \<Longrightarrow> \<exists>X. (\<exists>i. X = power \<langle>R\<rangle> i) \<and> xs \<in> X"
proof (induct xs rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    apply (rule_tac x = "power \<langle>R\<rangle> 0" in exI)
    apply auto
    apply (rule_tac x = 0 in exI)
    by auto
next
  case (lfinite_LConsI xs x)
  then obtain X and i where "X = Language.power \<langle>R\<rangle> i" and "xs \<in> X"
    by - (auto dest: lset_LCons_subsetD)
  from this show ?case
    apply (rule_tac x = "\<langle>R\<rangle> \<cdot> X" in exI)
    apply auto
    apply (rule_tac x = "Suc i" in exI)
    apply auto
    apply (subst fin_l_prod)
    apply auto
    apply (rule_tac x = "LCons x LNil" in exI)
    apply (rule_tac x = xs in exI)
    apply auto
    apply (insert lfinite_LConsI(3))
    by (simp add: atomic_def)
qed

lemma rely_def: "\<langle>R\<rangle>\<^sup>\<star> = {xs. lfinite xs \<and> lset xs \<subseteq> R}"
  apply (subst star_power_fin)
  apply (auto simp add: powers_def)
  apply (metis rely_power1)
  apply (metis rely_power2)
  by (metis rely_power3)

lemma lset_lefts [iff]: "lset (\<ll> xs) \<subseteq> R \<longleftrightarrow> lset (lfilter is_left xs) \<subseteq> Inl ` R"
  apply (auto simp add: lefts_def image_def subset_iff)
  apply (erule_tac x = "unl t" in allE)
  apply (erule impE)
  apply (rule_tac x = t in exI)
  apply auto
  apply (rule_tac x = "unl t" in bexI)
  apply auto
  apply (subgoal_tac "\<exists>t' t''. t = Inl t' \<or> t = Inr t''")
  apply (erule exE)+
  apply (erule disjE)
  apply simp_all
  by (metis swap.cases)

lemma lset_rights [iff]: "lset (\<rr> xs) \<subseteq> R \<longleftrightarrow> lset (lfilter is_right xs) \<subseteq> Inr ` R"
  apply (auto simp add: rights_def image_def subset_iff)
  apply (erule_tac x = "unr t" in allE)
  apply (erule impE)
  apply (rule_tac x = t in exI)
  apply auto
  apply (rule_tac x = "unr t" in bexI)
  apply auto
  apply (subgoal_tac "\<exists>t' t''. t = Inl t' \<or> t = Inr t''")
  apply (erule exE)+
  apply (erule disjE)
  apply simp_all
  by (metis swap.cases)

lemma lset_lr [intro]: "lset (\<ll> xs) \<subseteq> R \<Longrightarrow> lset (\<rr> xs) \<subseteq> S \<Longrightarrow> lset (lmap \<langle>id,id\<rangle> xs) \<subseteq> R \<union> S"
  apply simp
  apply (auto simp add: subset_iff)
  by (metis (full_types) DEADID.map_id Projr_Inr imageE not_is_right sum.simps(5) sum.simps(6) unl.simps(1))

lemma rely_union1: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star> \<subseteq> \<langle>R \<union> S\<rangle>\<^sup>\<star>"
  apply (simp add: rely_def shuffle_def Sup_le_iff)
  apply clarify
  apply (intro conjI)
  apply (metis lfinite_lmap lfinite_shuffle)
  apply (simp add: tshuffle_words_def)
  by (metis llist.set_map lset_lr)

lemma lmap_unl_Inl: "(\<forall>x\<in>lset xs. is_left x) \<Longrightarrow> lmap unl xs = ys \<longleftrightarrow> xs = lmap Inl ys"
  apply (auto simp del: lmap.compositionality)
  apply (rule sym)
  apply (rule lmap2_id_var)
  apply auto
  by (metis is_left.simps(2) obj_sumE unl.simps(1))

lemma lmap_unr_Inr: "(\<forall>x\<in>lset xs. is_right x) \<Longrightarrow> lmap unr xs = ys \<longleftrightarrow> xs = lmap Inr ys"
  apply (auto simp del: lmap.compositionality)
  apply (rule sym)
  apply (rule lmap2_id_var)
  apply auto
  by (metis is_right.simps(2) obj_sumE unr.simps(1))

lemma lmap_subid: "(\<forall>x\<in>lset xs. f x = x) \<Longrightarrow> lmap f xs = xs"
  by auto

lemma lfilter_to_lfilter_left [symmetric]: "lfilter P xs = \<ll> (lmap (\<lambda>x. if P x then Inl x else Inr x) xs)"
  apply (auto simp add: lefts_def)
  apply (rule sym)
  apply (subst lmap_unl_Inl)
  by (auto simp add: lfilter_lmap)

lemma lfilter_to_lfilter_right [symmetric]: "lfilter (Not \<circ> P) xs = \<rr> (lmap (\<lambda>x. if P x then Inl x else Inr x) xs)"
  apply (auto simp add: rights_def)
  apply (rule sym)
  apply (subst lmap_unr_Inr)
  by (auto simp add: lfilter_lmap)

lemma lfilter_interleave:
  "xs = lmap \<langle>id,id\<rangle> (lfilter P xs \<triangleright> traj (lmap (\<lambda>x. if P x then Inl () else Inr ()) xs) \<triangleleft> lfilter (Not \<circ> P) xs)"
proof -
  have traj_lmap: "traj (lmap (\<lambda>x. if P x then Inl () else Inr ()) xs) = traj (lmap (\<lambda>x. if P x then Inl x else Inr x) xs)"
    by (auto simp add: traj_def) (metis (lifting, full_types) sum.simps(5) sum.simps(6))

  have "xs = lmap \<langle>id,id\<rangle> (lmap (\<lambda>x. if P x then Inl x else Inr x) xs)"
    by (rule sym) (auto intro: lmap_subid)
  also have "... = lmap \<langle>id,id\<rangle> (\<ll> (lmap (\<lambda>x. if P x then Inl x else Inr x) xs) \<triangleright> traj (lmap (\<lambda>x. if P x then Inl x else Inr x) xs) \<triangleleft> \<rr> (lmap (\<lambda>x. if P x then Inl x else Inr x) xs))"
    by (simp only: reinterleave)
  also have "... = lmap \<langle>id,id\<rangle> (lfilter P xs \<triangleright> traj (lmap (\<lambda>x. if P x then Inl () else Inr ()) xs) \<triangleleft> lfilter (Not \<circ> P) xs)"
    by (simp only: traj_lmap lfilter_to_lfilter_left lfilter_to_lfilter_right)
  finally show ?thesis .
qed

lemma rely_union [simp]: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star> = \<langle>R \<union> S\<rangle>\<^sup>\<star>"
proof
  show "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star> \<subseteq> \<langle>R \<union> S\<rangle>\<^sup>\<star>"
    apply (simp add: rely_def shuffle_def Sup_le_iff)
    apply clarify
    apply (intro conjI)
    apply (metis lfinite_lmap lfinite_shuffle)
    apply (simp add: tshuffle_words_def)
    by (metis llist.set_map lset_lr)
next
  {
    fix xs
    assume assm: "xs \<in> \<langle>R \<union> S\<rangle>\<^sup>\<star>"
    hence "lfinite xs"
      by (auto simp add: rely_def)
    have "xs = lmap \<langle>id,id\<rangle> (lfilter (\<lambda>x. x \<in> R) xs \<triangleright> traj (lmap (\<lambda>x. if x \<in> R then Inl () else Inr ()) xs) \<triangleleft> lfilter (\<lambda>x. x \<notin> R) xs)"
      by (subst lfilter_interleave[where P = "\<lambda>x. x \<in> R"], simp)
    also have "... \<in> lmap \<langle>id,id\<rangle> ` (lfilter (\<lambda>x. x \<in> R) xs \<sha> lfilter (\<lambda>x. x \<notin> R) xs)"
      apply (intro imageI)
      apply (simp add: tshuffle_words_def image_def)
      apply (subst lefts_interleave_llength)
      defer
      apply (subst rights_interleave_llength)
      apply auto
      by (simp_all add: lefts_def rights_def lfilter_lmap)
    also have "... \<subseteq> \<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star>"
      apply (auto simp add: rely_def shuffle_def)
      apply (rule_tac x = "lmap \<langle>id,id\<rangle> ` (lfilter (\<lambda>x. x \<in> R) xs \<sha> lfilter (\<lambda>x. x \<notin> R) xs)" in exI)
      apply simp
      apply (rule_tac x = "lfilter (\<lambda>x. x \<in> R) xs" in exI)
      apply (rule_tac x = "lfilter (\<lambda>x. x \<notin> R) xs" in exI)
      apply auto
      apply (metis `lfinite xs` lfinite_lfilterI)
      apply (metis `lfinite xs` lfinite_lfilterI)
      apply (insert assm)
      by (auto simp add: rely_def)
    finally have "xs \<in> \<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star>" .
  }
  thus "\<langle>R \<union> S\<rangle>\<^sup>\<star> \<subseteq> \<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star>"
    by blast
qed

lemmas [intro] = seq.star_iso[rule_format]

lemma rely_1: "\<langle>R\<rangle>\<^sup>\<star> \<le> \<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>S\<rangle>\<^sup>\<star>"
  by (auto del: subsetI)

lemma rely_2: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>R\<rangle>\<^sup>\<star> \<subseteq> \<langle>R\<rangle>\<^sup>\<star>"
  by auto

lemma rely_par_idem: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> \<langle>R\<rangle>\<^sup>\<star> = \<langle>R\<rangle>\<^sup>\<star>"
  by (metis rely_union sup_idem)

lemma rely_inter: "\<langle>R\<rangle>\<^sup>\<star> \<inter> \<langle>S\<rangle>\<^sup>\<star> = \<langle>R \<inter> S\<rangle>\<^sup>\<star>"
  by (auto simp add: rely_def)

lemma rely_lappend [simp]: "(\<exists>rs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> rs = rs' \<frown> rs'') \<longleftrightarrow> (rs' \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> rs'' \<in> \<langle>R\<rangle>\<^sup>\<star>)"
  by (auto simp add: rely_def FIN_def)

lemma LCons_cont [simp]: "LCons x ` \<Union>{f xs ys|xs ys. P xs ys} = \<Union>{LCons x ` f xs ys|xs ys. P xs ys}"
  by (auto simp add: image_def)

lemma set_comp_Union_iso3: "(\<And>x y z. P x y z \<Longrightarrow> f x y z \<subseteq> g x y z) \<Longrightarrow> \<Union>{f x y z |x y z. P x y z} \<subseteq> \<Union>{g x y z |x y z. P x y z}"
  by auto (metis in_mono)

lemma set_comp_Union_eq4: "(\<And>x y z w. P x y z w \<Longrightarrow> f x y z w = g x y z w) \<Longrightarrow> \<Union>{f x y z w |x y z w. P x y z w} = \<Union>{g x y z w |x y z w. P x y z w}"
  by auto metis+

lemma set_comp_Union_eq3: "(\<And>x y z. P x y z \<Longrightarrow> f x y z = g x y z) \<Longrightarrow> \<Union>{f x y z |x y z. P x y z} = \<Union>{g x y z |x y z. P x y z}"
  by auto metis+

lemma set_comp_Union_eq2: "(\<And>x y z. P x y \<Longrightarrow> f x y = g x y) \<Longrightarrow> \<Union>{f x y |x y. P x y} = \<Union>{g x y |x y. P x y}"
  by auto

lemma lappend_in_l_prod: "lfinite xs \<Longrightarrow> xs \<in> X \<Longrightarrow> ys \<in> Y \<Longrightarrow> xs \<frown> ys \<in> X \<cdot> Y"
  by (auto simp add: l_prod_def)

lemma [simp]: "lmap \<langle>id,id\<rangle> ` (x \<cdot> y) = lmap \<langle>id,id\<rangle> ` x \<cdot> lmap \<langle>id,id\<rangle> ` y"
  apply (simp add: image_def)
  apply (auto simp add: l_prod_def)
  apply (metis lfinite_lmap lmap_lappend_distrib)
  apply (metis lfinite_lmap lmap_lappend_distrib)
  by (metis l_prod_def lappend_in_l_prod lmap_lappend_distrib par.add_comm)

lemma rely_finite: "\<langle>R\<rangle>\<^sup>\<star> \<subseteq> FIN"
  by (auto simp add: rely_def FIN_def)

lemma tshuffle_image1: "LCons (Inl x) ` (xs \<sha> ys) \<subseteq> LCons x xs \<sha> ys"
  by (auto simp add: tshuffle_words_def)

lemma tshuffle_image2: "LCons (Inr y) ` (xs \<sha> ys) \<subseteq> xs \<sha> LCons y ys"
  by (auto simp add: tshuffle_words_def)

lemma rely_dist: "lfinite rs \<Longrightarrow> lfinite xs \<Longrightarrow> rs \<sha> (xs \<frown> ys) \<subseteq> \<Union>{(rs' \<sha> xs) \<cdot> (rs'' \<sha> ys) |rs' rs''. rs = rs' \<frown> rs''}"
proof (induct rs arbitrary: xs rule: lfinite_induct)
  case Nil
  thus ?case
    by (auto simp add: l_prod_def lmap_lappend_distrib)
next
  case (Cons r rs) note ih_rs = this
  from Cons.prems show ?case
  proof (induct xs rule: lfinite_induct)
    case Nil
    show ?case
      apply auto
      apply (rule_tac x = "LCons r rs \<sha> ys" in exI)
      apply simp
      apply (rule_tac x = LNil in exI)
      by simp
  next
    case (Cons z zs)
    hence z_zs_finite: "lfinite (LCons z zs)"
      by (metis lfinite_LCons)
    have "LCons r rs \<sha> (LCons z zs \<frown> ys) = LCons r rs \<sha> (LCons z (zs \<frown> ys))"
      by simp
    also have "... = LCons (Inl r) ` (rs \<sha> LCons z (zs \<frown> ys)) \<union> LCons (Inr z) ` (LCons r rs \<sha> (zs \<frown> ys))"
      by (simp only: LCons_tshuffle)
    also have "... = LCons (Inl r) ` (rs \<sha> (LCons z zs \<frown> ys)) \<union> LCons (Inr z) ` (LCons r rs \<sha> (zs \<frown> ys))"
      by simp
    also have "... \<subseteq> LCons (Inl r) ` \<Union>{(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. rs = rs' \<frown> rs''} \<union> LCons (Inr z) ` \<Union>{(rs' \<sha> zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. LCons r rs = rs' \<frown> rs''}"
      by (rule sup_mono[OF image_mono[OF ih_rs(2)[OF z_zs_finite]] image_mono[OF Cons(2)]])
    also have "... = \<Union>{LCons (Inl r) ` ((rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys)) |rs' rs''. rs = rs' \<frown> rs''} \<union> \<Union>{LCons (Inr z) ` ((rs' \<sha> zs) \<cdot> (rs'' \<sha> ys)) |rs' rs''. LCons r rs = rs' \<frown> rs''}"
      by simp
    also have "... \<subseteq> \<Union>{(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. LCons r rs = rs' \<frown> rs''} \<union> \<Union>{LCons (Inr z) ` ((rs' \<sha> zs) \<cdot> (rs'' \<sha> ys)) |rs' rs''. LCons r rs = rs' \<frown> rs''}"
      apply (rule sup_mono[OF _ order_refl])
      apply (rule Sup_mono)
      apply auto
      apply (rule_tac x = "(LCons r rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys)" in exI)
      apply (intro conjI)
      apply (rule_tac x = "LCons r rs'" in exI)
      apply (rule_tac x = rs'' in exI)
      apply simp
      by (intro l_prod_isol tshuffle_image1)
    also have "... \<subseteq> \<Union>{(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. LCons r rs = rs' \<frown> rs''} \<union> \<Union>{(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. LCons r rs = rs' \<frown> rs''}"
      apply (rule sup_mono[OF order_refl _])
      apply (rule Sup_mono)
      apply auto
      apply (rule_tac x = "(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys)" in exI)
      apply (intro conjI)
      apply (rule_tac x = rs' in exI)
      apply (rule_tac x = rs'' in exI)
      apply simp
      by (intro l_prod_isol tshuffle_image2)
    also have "... = \<Union>{(rs' \<sha> LCons z zs) \<cdot> (rs'' \<sha> ys) |rs' rs''. LCons r rs = rs' \<frown> rs''}"
      by simp
    finally show ?case .
  qed
qed

lemma fin_inf_split: "x \<inter> FIN \<union> x\<cdot>{} = x"
  by (auto simp add: l_prod_def FIN_def)

lemma rely_exchange: "(\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y) \<subseteq> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x \<cdot> y"
proof -
  have "(\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y) = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> (x \<inter> FIN \<union> x\<cdot>{})) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y)"
    by (metis fin_inf_split)
  also have "... = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> (x \<inter> FIN)) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y) \<union> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<cdot>{}" using rely_finite[of R]
    by simp
  also have "... \<subseteq> (x \<inter> FIN) \<cdot> y \<parallel> \<langle>R\<rangle>\<^sup>\<star> \<cdot> \<langle>R\<rangle>\<^sup>\<star> \<union> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<cdot>{}"
    by (subst shuffle_comm) (intro Un_mono order_refl exchange rely_finite Int_lower2)
  also have "... = \<langle>R\<rangle>\<^sup>\<star> \<parallel> (x \<inter> FIN) \<cdot> y \<union> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<cdot>{}"
    by (metis seq.star_trans_eq shuffle_comm)
  also have "... = \<langle>R\<rangle>\<^sup>\<star> \<parallel> ((x \<inter> FIN) \<cdot> y \<union> x\<cdot>{})"
    by simp
  also have "... = \<langle>R\<rangle>\<^sup>\<star> \<parallel> ((x \<inter> FIN) \<cdot> y \<union> x \<cdot> {} \<cdot> y)"
    by simp
  also have "... = \<langle>R\<rangle>\<^sup>\<star> \<parallel> x \<cdot> y"
    by (metis fin_inf_split seq.distrib_right')
  finally show ?thesis .
qed

lemma rely_l_prod1: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> x \<cdot> y \<subseteq> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y)"
proof -
  let ?lhs_inf = "\<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> \<not> lfinite xs}"
  let ?lhs_fin = "\<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> (xs \<frown> ys)) |rs xs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"

  have inf_case: "?lhs_inf \<subseteq> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x} \<cdot> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> ys) |rs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> ys \<in> y}"
    by (auto simp only: l_prod_def) (metis (lifting, full_types) lfinite_lmap lfinite_rights mem_Collect_eq tshuffle_words_def)

  have "?lhs_fin \<subseteq> \<Union>{lmap \<langle>id,id\<rangle> ` \<Union>{(rs' \<sha> xs) \<cdot> (rs'' \<sha> ys) |rs' rs''. rs = rs' \<frown> rs''} |rs xs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by (intro set_comp_Union_iso3 image_mono rely_dist) (auto simp add: rely_def FIN_def)
  also have "... \<subseteq> \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` ((rs' \<sha> xs) \<cdot> (rs'' \<sha> ys)) |rs' rs''. rs = rs' \<frown> rs''} |rs xs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by (rule set_comp_Union_iso3) blast
  also have "... = \<Union>{\<Union>{lmap \<langle>id,id\<rangle> ` (rs' \<sha> xs) \<cdot> lmap \<langle>id,id\<rangle> ` (rs'' \<sha> ys) |rs' rs''. rs = rs' \<frown> rs''} |rs xs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by simp
  also have "... = \<Union>{lmap \<langle>id,id\<rangle> ` (rs' \<sha> xs) \<cdot> lmap \<langle>id,id\<rangle> ` (rs'' \<sha> ys) |rs' rs'' rs xs ys. rs = rs' \<frown> rs'' \<and> rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by blast
  also have "... = \<Union>{lmap \<langle>id,id\<rangle> ` (rs' \<sha> xs) \<cdot> lmap \<langle>id,id\<rangle> ` (rs'' \<sha> ys) |rs' rs'' xs ys. (\<exists>rs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> rs = rs' \<frown> rs'') \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by blast
  also have "... = \<Union>{lmap \<langle>id,id\<rangle> ` (rs' \<sha> xs) \<cdot> lmap \<langle>id,id\<rangle> ` (rs'' \<sha> ys) |rs' rs'' xs ys. rs' \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> rs'' \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    by simp
  also have "... = \<Union>{{zs \<frown> ws |zs ws. zs \<in> lmap \<langle>id,id\<rangle> ` (rs' \<sha> xs) \<and> ws \<in> lmap \<langle>id,id\<rangle> ` (rs'' \<sha> ys)} |rs' rs'' xs ys. rs' \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> rs'' \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> ys \<in> y \<and> lfinite xs}"
    apply (rule set_comp_Union_eq4)
    apply (erule conjE)
    apply (subst fin_l_prod)
    apply (auto simp add: FIN_def)
    by (metis (full_types) FIN_def in_mono lfinite_shuffle mem_Collect_eq rely_finite)
  also have "... = \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x \<and> lfinite xs} \<cdot> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> ys) |rs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> ys \<in> y}"
    apply (subst fin_l_prod)
    apply (simp add: FIN_def)
    apply clarify
    apply (metis (full_types) FIN_def lfinite_lmap lfinite_shuffle mem_Collect_eq rely_finite set_mp)
    by blast
  also have "... \<subseteq> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x} \<cdot> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> ys) |rs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> ys \<in> y}"
    by (auto intro!: l_prod_isol)
  finally have fin_case: "?lhs_fin \<subseteq> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x} \<cdot> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> ys) |rs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> ys \<in> y}" .

  have "\<langle>R\<rangle>\<^sup>\<star> \<parallel> x \<cdot> y = \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> zs) |rs zs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> zs \<in> x \<cdot> y}"
    by (simp add: shuffle_def)
  also have "... = ?lhs_inf \<union> ?lhs_fin"
    by (simp add: l_prod_def) blast
  also have "... \<subseteq> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> xs) |rs xs. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> xs \<in> x} \<cdot> \<Union>{lmap \<langle>id,id\<rangle> ` (rs \<sha> ys) |rs ys. rs \<in> \<langle>R\<rangle>\<^sup>\<star> \<and> ys \<in> y}"
    by (subst Un_absorb[symmetric], rule sup_mono[OF inf_case fin_case])
  also have "... = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y)"
    by (simp add: shuffle_def)
  finally show ?thesis .
qed

lemma rely_l_prod [simp]: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> x \<cdot> y = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> y)"
  by (metis rely_exchange rely_l_prod1 subset_antisym)

lemma rely_star1: "(\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<subseteq> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<^sup>\<star>"
  apply (subst star_def)
  apply (rule fp_induct)
  apply (metis par.add_iso_var seq.mult_isol seq.star_ref seq.star_zero)
  apply (simp only: le_sup_iff)
  apply (intro conjI)
  apply (metis order.trans par.mult.left_neutral par.mult_isor seq.star_ref)
  by (metis par.mult_isor rely_l_prod seq.star_1l shuffle_comm)

lemma rely_star2: "(\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) \<subseteq> \<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<^sup>\<star> \<cdot> x"
  by (metis par.mult_isol rely_l_prod rely_star1 seq.mult_isol_var seq.star_trans seq.star_trans_eq shuffle_comm)

lemma rely_power: "\<langle>R\<rangle>\<^sup>\<star> \<parallel> power x i \<cdot> x = power (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) i \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
  by (induct i) (simp_all add: seq.mult_assoc)

lemma rely_star:
  assumes "x \<subseteq> FIN"
  shows "\<langle>R\<rangle>\<^sup>\<star> \<parallel> (x\<^sup>\<star> \<cdot> x) = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
proof -
  have "\<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<^sup>\<star> \<cdot> x = \<langle>R\<rangle>\<^sup>\<star> \<parallel> (\<Union>powers x) \<cdot> x"
    by (metis assms star_power_fin)
  also have "... = \<Union>{\<langle>R\<rangle>\<^sup>\<star> \<parallel> power x i \<cdot> x |i. True}"
    by (auto simp add: shuffle_inf_dist l_prod_inf_distr powers_def) (metis rely_l_prod)
  also have "... = \<Union>{power (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) i \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) |i. True}"
    by (simp only: rely_power)
  also have "... = \<Union>{power (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) i |i. True} \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
    by (auto simp add: l_prod_inf_distr)
  also have "... = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
    by (metis assms fin_shuffle powers_def rely_finite star_power_fin)
  finally show ?thesis .
qed

lemma rely_star4:
  assumes "x \<cdot> {} = x"
  shows "\<langle>R\<rangle>\<^sup>\<star> \<parallel> (x\<^sup>\<star> \<cdot> x) = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
proof -
  have "\<langle>R\<rangle>\<^sup>\<star> \<parallel> x\<^sup>\<star> \<cdot> x = \<langle>R\<rangle>\<^sup>\<star> \<parallel> (\<Union>powers x) \<cdot> x"
    by (metis assms star_power_inf)
  also have "... = \<Union>{\<langle>R\<rangle>\<^sup>\<star> \<parallel> power x i \<cdot> x |i. True}"
    by (auto simp add: shuffle_inf_dist l_prod_inf_distr powers_def) (metis rely_l_prod)
  also have "... = \<Union>{power (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) i \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) |i. True}"
    by (simp only: rely_power)
  also have "... = \<Union>{power (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x) i |i. True} \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
    by (auto simp add: l_prod_inf_distr)
  also have "... = (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)\<^sup>\<star> \<cdot> (\<langle>R\<rangle>\<^sup>\<star> \<parallel> x)"
    by (metis assms par.annir powers_def rely_l_prod star_power_inf)
  finally show ?thesis .
qed

definition stutter :: "('a \<times> 'a) lan" where
  "stutter = \<langle>Id_on UNIV\<rangle>\<^sup>\<star>"

end