\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Galois Property\<close>
theory Transport_Functions_Galois_Property
  imports
    Transport_Functions_Monotone
begin

paragraph \<open>Dependent Function Relator\<close>

context transport_Dep_Fun_Rel
begin

context
begin

interpretation flip : transport_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma left_right_rel_if_left_rel_rightI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and half_galois_prop_left1: "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and refl_R1: "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and half_galois_prop_left2: "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)) (l2\<^bsub> x' (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and R2_le1: "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and R2_le2: "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and ge_L2_r2_le2: "\<And>x' y'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) y' \<Longrightarrow>
    (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub> y') \<le> (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub> y')"
  and trans_R2: "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "g \<le>\<^bsub>R\<^esub> g"
  and "f \<le>\<^bsub>L\<^esub> r g"
  shows "l f \<le>\<^bsub>R\<^esub> g"
proof (rule flip.left_relI)
  fix x1' x2'
  assume [iff]: "x1' \<le>\<^bsub>R1\<^esub> x2'"
  with refl_R1 have [iff]: "x1' \<le>\<^bsub>R1\<^esub> x1'" by auto
  with mono_r1 half_galois_prop_left1 have [iff]: "\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> x1'"
    by (intro t1.counit_rel_if_right_rel_if_half_galois_prop_left_if_mono_wrt_rel)
  with refl_R1 have "\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 x1'" by blast
  with \<open>g \<le>\<^bsub>R\<^esub> g\<close> have "g (\<epsilon>\<^sub>1 x1') \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') (\<epsilon>\<^sub>1 x1')\<^esub> g (\<epsilon>\<^sub>1 x1')" by blast
  with R2_le2 have "g (\<epsilon>\<^sub>1 x1') \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g (\<epsilon>\<^sub>1 x1')" by blast

  let ?x1 = "r1 x1'"
  from \<open>f \<le>\<^bsub>L\<^esub> r g\<close> \<open>x1' \<le>\<^bsub>R1\<^esub> x1'\<close> have "f ?x1 \<le>\<^bsub>L2 ?x1 ?x1\<^esub> r g ?x1" using mono_r1 by blast
  then have "f ?x1 \<le>\<^bsub>L2 ?x1 ?x1\<^esub> r2\<^bsub>?x1 (\<epsilon>\<^sub>1 x1')\<^esub> (g (\<epsilon>\<^sub>1 x1'))" by simp
  with ge_L2_r2_le2 have "f ?x1 \<le>\<^bsub>L2 ?x1 ?x1\<^esub> r2\<^bsub>?x1 x1'\<^esub> (g (\<epsilon>\<^sub>1 x1'))"
    using \<open>_ \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g (\<epsilon>\<^sub>1 x1')\<close> by blast
  with half_galois_prop_left2 have "l2\<^bsub> x1' ?x1\<^esub> (f ?x1) \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g (\<epsilon>\<^sub>1 x1')"
    using \<open>_ \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g (\<epsilon>\<^sub>1 x1')\<close> by auto
  moreover from \<open>g \<le>\<^bsub>R\<^esub> g\<close> \<open>\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> x1'\<close> have "... \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g x1'" by blast
  ultimately have "l2\<^bsub> x1' ?x1\<^esub> (f ?x1) \<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x1'\<^esub> g x1'" using trans_R2 by blast
  with R2_le1 R2_le2 have "l2\<^bsub> x1' ?x1\<^esub> (f ?x1) \<le>\<^bsub>R2 x1' x2'\<^esub> g x1'" by blast
  moreover from \<open>g \<le>\<^bsub>R\<^esub> g\<close> \<open>x1' \<le>\<^bsub>R1\<^esub> x2'\<close> have "... \<le>\<^bsub>R2 x1' x2'\<^esub> g x2'" by blast
  ultimately have "l2\<^bsub> x1' ?x1\<^esub> (f ?x1) \<le>\<^bsub>R2 x1' x2'\<^esub> g x2'" using trans_R2 by blast
  then show "l f x1' \<le>\<^bsub>R2 x1' x2'\<^esub> g x2'" by simp
qed

lemma left_right_rel_if_left_rel_right_ge_left2_assmI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>))
    (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "x' \<le>\<^bsub>R1\<^esub> x'"
  and "in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) y'"
  shows "(\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub> y') \<le> (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub> y')"
  using dep_mono_wrt_relD[OF mono_r1 \<open>x' \<le>\<^bsub>R1\<^esub> x'\<close>] assms(2-4,6)
  by (blast dest!: t1.half_galois_prop_leftD)

interpretation flip_inv :
  transport_Dep_Fun_Rel "(\<ge>\<^bsub>R1\<^esub>)" "(\<ge>\<^bsub>L1\<^esub>)" r1 l1 "flip2 R2" "flip2 L2" r2 l2
  rewrites "flip_inv.L \<equiv> (\<ge>\<^bsub>R\<^esub>)" and "flip_inv.R \<equiv> (\<ge>\<^bsub>L\<^esub>)"
  and "flip_inv.t1.counit \<equiv> \<eta>\<^sub>1"
  and "\<And>R x y. (flip2 R x y)\<inverse> \<equiv> R y x"
  and "\<And>R. in_dom R\<inverse> \<equiv> in_codom R"
  and "\<And>R x1 x2. in_codom (flip2 R x1 x2) \<equiv> in_dom (R x2 x1)"
  and "\<And>R S. (R\<inverse> \<Rrightarrow>\<^sub>m S\<inverse>) \<equiv> (R \<Rrightarrow>\<^sub>m S)"
  and "\<And>R S x1 x2 x1' x2'. (flip2 R x1 x2 \<^sub>h\<unlhd> flip2 S x1' x2') \<equiv> (S x2' x1' \<unlhd>\<^sub>h R x2 x1)\<inverse>"
  and "\<And>R S. (R\<inverse> \<^sub>h\<unlhd> S\<inverse>) \<equiv> (S \<unlhd>\<^sub>h R)\<inverse>"
  and "\<And>x1 x2 x3 x4. flip2 L2 x1 x2 \<le> flip2 L2 x3 x4 \<equiv> (\<le>\<^bsub>L2 x2 x1\<^esub>) \<le> (\<le>\<^bsub>L2 x4 x3\<^esub>)"
  and "\<And>(R :: 'z \<Rightarrow> _) (P :: 'z \<Rightarrow> bool). reflexive_on P R\<inverse> \<equiv> reflexive_on P R"
  and "\<And>R x1 x2. transitive (flip2 R x1 x2) \<equiv> transitive (R x2 x1)"
  and "\<And>x x. ([in_dom (\<le>\<^bsub>L2 x' \<eta>\<^sub>1 x'\<^esub>)] \<Rrightarrow> flip2 R2 (l1 x') (l1 x'))
    \<equiv> ([in_dom (\<le>\<^bsub>L2 x' \<eta>\<^sub>1 x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x') (l1 x')\<^esub>))\<inverse>"
  by (simp_all add: flip_inv_left_eq_ge_right flip_inv_right_eq_ge_left
    t1.flip_counit_eq_unit
    galois_prop.rel_inv_half_galois_prop_right_eq_half_galois_prop_left_rel_inv)

lemma left_rel_right_if_left_right_relI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> ((\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (r2\<^bsub>x (l1 x)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x y. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) y \<Longrightarrow>
    (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub> y) \<le> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) x\<^esub> y)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "l f \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g"
  using assms
  by (intro flip_inv.left_right_rel_if_left_rel_rightI[simplified rel_inv_iff_rel])

lemma left_rel_right_if_left_right_rel_le_right2_assmI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>))\<inverse> r1 l1"
  and "([in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "x \<le>\<^bsub>L1\<^esub> x"
  and "in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) y"
  shows "(\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub> y) \<le> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) x\<^esub> y)"
  using assms by (intro flip_inv.left_right_rel_if_left_rel_right_ge_left2_assmI
    [simplified rel_inv_iff_rel])
  auto

end

lemma left_rel_right_iff_left_right_relI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)) (l2\<^bsub> x' (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> ((\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (r2\<^bsub>x (l1 x)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x y. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) y \<Longrightarrow>
    (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub> y) \<le> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) x\<^esub> y)"
  and "\<And>x' y'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) y' \<Longrightarrow>
    (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub> y') \<le> (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub> y')"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "g \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g \<longleftrightarrow> l f \<le>\<^bsub>R\<^esub> g"
  using assms by (intro iffI left_right_rel_if_left_rel_rightI)
  (auto intro!: left_rel_right_if_left_right_relI)

lemma half_galois_prop_left2_if_half_galois_prop_left2_if_GaloisI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x' \<le>\<^bsub>R1\<^esub> x'"
  shows "((\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)) (l2\<^bsub> x' (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  using assms by (auto intro: t1.right_Galois_if_right_relI)

lemma half_galois_prop_right2_if_half_galois_prop_right2_if_GaloisI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x \<le>\<^bsub>L1\<^esub> x"
  shows "((\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (r2\<^bsub>x (l1 x)\<^esub>)"
  by (auto intro!: assms t1.Galois_left_if_left_relI)

lemma left_rel_right_iff_left_right_relI':
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and galois_prop2: "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>)) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "g \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g \<longleftrightarrow> l f \<le>\<^bsub>R\<^esub> g"
proof -
  from galois_prop2 have
    "((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
    "((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
    if "x \<^bsub>L1\<^esub>\<lessapprox> x'" for x x'
    using \<open>x \<^bsub>L1\<^esub>\<lessapprox> x'\<close> by blast+
  with assms show ?thesis
    by (intro left_rel_right_iff_left_right_relI
      left_right_rel_if_left_rel_right_ge_left2_assmI
      left_rel_right_if_left_right_rel_le_right2_assmI
      half_galois_prop_left2_if_half_galois_prop_left2_if_GaloisI
      half_galois_prop_right2_if_half_galois_prop_right2_if_GaloisI)
    auto
qed

lemma left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_leftI:
  assumes galois_conn1: "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and refl_L1: "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and antimono_L2:
    "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | (x2 \<le>\<^bsub>L1\<^esub> x3 \<and> x4 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x3)] \<Rrightarrow> (\<ge>)) L2"
  shows "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
proof -
  fix x1 x2 assume "x1 \<le>\<^bsub>L1\<^esub> x2"
  with galois_conn1 refl_L1 have "x1 \<le>\<^bsub>L1\<^esub> x1" "x2 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x2"
    by (blast intro:
      t1.rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel)+
  moreover with refl_L1 have "x2 \<le>\<^bsub>L1\<^esub> x2" "\<eta>\<^sub>1 x2 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x2" by auto
  moreover note dep_mono_wrt_relD[OF antimono_L2 \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close>]
    and dep_mono_wrt_relD[OF antimono_L2 \<open>x1 \<le>\<^bsub>L1\<^esub> x1\<close>]
  ultimately show "(\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)" "(\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
    using \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> by auto
qed

lemma left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_rightI:
  assumes galois_conn1: "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and refl_R1: "reflexive_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and mono_R2:
    "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | \<epsilon>\<^sub>1 x2' \<le>\<^bsub>R1\<^esub> x1'] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  shows "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
proof -
  fix x1' x2' assume "x1' \<le>\<^bsub>R1\<^esub> x2'"
  with galois_conn1 refl_R1 have "x2' \<le>\<^bsub>R1\<^esub> x2'" "\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> x1'"
    by (blast intro:
      t1.counit_rel_if_right_rel_if_half_galois_prop_left_if_mono_wrt_rel)+
  moreover with refl_R1 have "x1' \<le>\<^bsub>R1\<^esub> x1'" "\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 x1'" by auto
  moreover note dep_mono_wrt_relD[OF mono_R2 \<open>\<epsilon>\<^sub>1 x1' \<le>\<^bsub>R1\<^esub> x1'\<close>]
    and dep_mono_wrt_relD[OF mono_R2 \<open>x1' \<le>\<^bsub>R1\<^esub> x1'\<close>]
  ultimately show "(\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)" "(\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
    using \<open>x1' \<le>\<^bsub>R1\<^esub> x2'\<close> by auto
qed

corollary left_rel_right_iff_left_right_rel_if_monoI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | (x2 \<le>\<^bsub>L1\<^esub> x3 \<and> x4 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x3)] \<Rrightarrow> (\<ge>)) L2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | \<epsilon>\<^sub>1 x2' \<le>\<^bsub>R1\<^esub> x1'] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>)) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "g \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g \<longleftrightarrow> l f \<le>\<^bsub>R\<^esub> g"
  using assms by (intro left_rel_right_iff_left_right_relI'
    left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_leftI
    left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_rightI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on
    in_field_if_in_dom in_field_if_in_codom)

end

paragraph \<open>Function Relator\<close>

context transport_Fun_Rel
begin

corollary left_right_rel_if_left_rel_rightI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>R2\<^esub>)"
  and "g \<le>\<^bsub>R\<^esub> g"
  and "f \<le>\<^bsub>L\<^esub> r g"
  shows "l f \<le>\<^bsub>R\<^esub> g"
  using assms by (intro tdfr.left_right_rel_if_left_rel_rightI) simp_all

corollary left_rel_right_if_left_right_relI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "l f \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g"
  using assms by (intro tdfr.left_rel_right_if_left_right_relI) simp_all

corollary left_rel_right_iff_left_right_relI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "transitive (\<le>\<^bsub>R2\<^esub>)"
  and "f \<le>\<^bsub>L\<^esub> f"
  and "g \<le>\<^bsub>R\<^esub> g"
  shows "f \<le>\<^bsub>L\<^esub> r g \<longleftrightarrow> l f \<le>\<^bsub>R\<^esub> g"
  using assms by (intro tdfr.left_rel_right_iff_left_right_relI) auto

end

paragraph \<open>Monotone Dependent Function Relator\<close>

context transport_Mono_Dep_Fun_Rel
begin

lemma half_galois_prop_left_left_rightI:
  assumes "(tdfr.L \<Rrightarrow>\<^sub>m tdfr.R) l"
  and "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)) (l2\<^bsub> x' (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x' y'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) y' \<Longrightarrow>
    (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub> y') \<le> (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub> y')"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding left_rel_eq_tdfr_left_Refl_Rel right_rel_eq_tdfr_right_Refl_Rel using assms
  by (intro
    half_galois_prop_leftI[unfolded left_rel_eq_tdfr_left_Refl_Rel right_rel_eq_tdfr_right_Refl_Rel]
    Refl_Rel_app_leftI[where ?f=l]
    tdfr.left_right_rel_if_left_rel_rightI)
  auto

lemma half_galois_prop_right_left_rightI:
  assumes "(tdfr.R \<Rrightarrow>\<^sub>m tdfr.L) r"
  and "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> ((\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (r2\<^bsub>x (l1 x)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x y. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) y \<Longrightarrow>
    (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub> y) \<le> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) x\<^esub> y)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding left_rel_eq_tdfr_left_Refl_Rel right_rel_eq_tdfr_right_Refl_Rel using assms
  by (intro
    half_galois_prop_rightI[unfolded left_rel_eq_tdfr_left_Refl_Rel right_rel_eq_tdfr_right_Refl_Rel]
    Refl_Rel_app_rightI[where ?f=r]
    tdfr.left_rel_right_if_left_right_relI)
  auto

corollary galois_prop_left_rightI:
  assumes "(tdfr.L \<Rrightarrow>\<^sub>m tdfr.R) l" and "(tdfr.R \<Rrightarrow>\<^sub>m tdfr.L) r"
  and "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)) (l2\<^bsub> x' (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> ((\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (r2\<^bsub>x (l1 x)\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x y. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) y \<Longrightarrow>
    (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub> y) \<le> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>) (l2\<^bsub>(l1 x) x\<^esub> y)"
  and "\<And>x' y'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) y' \<Longrightarrow>
    (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub> y') \<le> (\<ge>\<^bsub>L2 (r1 x') (r1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub> y')"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_propI half_galois_prop_left_left_rightI
    half_galois_prop_right_left_rightI)
  auto

corollary galois_prop_left_rightI':
  assumes "(tdfr.L \<Rrightarrow>\<^sub>m tdfr.R) l" and "(tdfr.R \<Rrightarrow>\<^sub>m tdfr.L) r"
  and "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and galois_prop2: "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow>
    ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow> (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>) \<le> (\<le>\<^bsub>R2 x' x'\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> (\<le>\<^bsub>R2 x1' x1'\<^esub>) \<le> (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>)) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  from galois_prop2 have
    "((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
    "((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
    if "x \<^bsub>L1\<^esub>\<lessapprox> x'" for x x'
    using \<open>x \<^bsub>L1\<^esub>\<lessapprox> x'\<close> by blast+
  with assms show ?thesis by (intro galois_prop_left_rightI
    tdfr.left_right_rel_if_left_rel_right_ge_left2_assmI
    tdfr.left_rel_right_if_left_right_rel_le_right2_assmI
    tdfr.half_galois_prop_left2_if_half_galois_prop_left2_if_GaloisI
    tdfr.half_galois_prop_right2_if_half_galois_prop_right2_if_GaloisI)
    auto
qed

corollary galois_prop_left_right_if_mono_if_galois_propI:
  assumes "(tdfr.L \<Rrightarrow>\<^sub>m tdfr.R) l" and "(tdfr.R \<Rrightarrow>\<^sub>m tdfr.L) r"
  and "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<unlhd> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | (x2 \<le>\<^bsub>L1\<^esub> x3 \<and> x4 \<le>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x3)] \<Rrightarrow> (\<ge>)) L2"
  and "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | \<epsilon>\<^sub>1 x2' \<le>\<^bsub>R1\<^esub> x1'] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow>
    ([in_dom (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x) (l1 x)\<^esub>)) (l2\<^bsub>(l1 x) x\<^esub>) (l2\<^bsub>(l1 x) (\<eta>\<^sub>1 x)\<^esub>)"
  and "\<And>x'. x' \<le>\<^bsub>R1\<^esub> x' \<Longrightarrow>
    ([in_codom (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x') x'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 (r1 x') (r1 x')\<^esub>)) (r2\<^bsub>(r1 x') (\<epsilon>\<^sub>1 x')\<^esub>) (r2\<^bsub>(r1 x') x'\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x1' x2'. x1' \<le>\<^bsub>R1\<^esub> x2' \<Longrightarrow> transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_prop_left_rightI'
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_leftI
    tdfr.left_rel_right_iff_left_right_rel_if_galois_prop_le_assms_rightI)
  (auto intro: reflexive_on_if_le_pred_if_reflexive_on
    in_field_if_in_dom in_field_if_in_codom)

text \<open>Note that we could further rewrite
@{thm "galois_prop_left_right_if_mono_if_galois_propI"},
as we will do later for Galois connections, by applying
@{thm "tdfr.mono_wrt_rel_leftI"} and @{thm "tdfr.mono_wrt_rel_rightI"} to the
first premises. However, this is not really helpful here.
Moreover, the resulting theorem will not result in a
useful lemma for the flipped instance of @{locale transport_Dep_Fun_Rel}
since @{thm "tdfr.mono_wrt_rel_leftI"} and @{thm "tdfr.mono_wrt_rel_rightI"} are
not flipped dual but only flipped-inversed dual.\<close>

end

paragraph \<open>Monotone Function Relator\<close>

context transport_Mono_Fun_Rel
begin

lemma half_galois_prop_left_left_rightI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>L2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>R2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (intro tpdfr.half_galois_prop_left_left_rightI tfr.mono_wrt_rel_leftI)
  simp_all

interpretation flip : transport_Mono_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma half_galois_prop_right_left_rightI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2\<^esub>)) r2"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (intro tpdfr.half_galois_prop_right_left_rightI flip.tfr.mono_wrt_rel_leftI)
  simp_all

corollary galois_prop_left_rightI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_dom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<stileturn> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "transitive (\<le>\<^bsub>R2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro tpdfr.galois_propI
    half_galois_prop_left_left_rightI half_galois_prop_right_left_rightI)
  auto

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)
(*<*)
theory EgTop
imports GenFilterSystem
begin
(*>*)

subsection \<open>\label{ssec:archprop}Architectural Properties\<close>

text \<open>
  Using the most generalised (untrusted) version of the system, we cannot show
  anything except architectural properties. These are true by construction of
  the generated system. To demonstrate this, we show a proof that the
  @{term client} and @{term store} instances cannot directly communicate.

  First we introduce some definitions to aid the statement of the property. A
  predicate specifying that a component sends on a given channel is defined as
  @{term sends_on}.
\<close>

fun
  sends_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
   "sends_on c (Request f _) = (\<exists>s. \<exists>q \<in> f s. q_channel q = c)"
 | "sends_on c (a ;; b) = (sends_on c a \<or> sends_on c b)"
 | "sends_on c (IF cond THEN a ELSE b) =
     (\<forall>s. cond s \<and> sends_on c a \<or> \<not> cond s \<and> sends_on c b)"
 | "sends_on c (WHILE cond DO a) = (\<forall>s. cond s \<and> sends_on c a \<or> \<not> cond s)"
 | "sends_on c (a \<squnion> b) = (sends_on c a \<or> sends_on c b)"
 | "sends_on _ _ = False"

text \<open>
  The corresponding predicate for receiving on a channel is defined as
  @{term receives_on}.
\<close>

fun
  receives_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
   "receives_on c (Response f) = (\<exists>q s. \<exists>a \<in> f q s. a_channel (snd a) = c)"
 | "receives_on c (a ;; b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on c (IF cond THEN a ELSE b) =
     (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s \<and> receives_on c b)"
 | "receives_on c (WHILE cond DO a) =
     (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s)"
 | "receives_on c (a \<squnion> b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on _ _ = False"

text \<open>
  Now whether a component communicates on a channel can be defined as the
  disjunction of these two.
\<close>

definition
  communicates_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
  "communicates_on ch c \<equiv> sends_on ch c \<or> receives_on ch c"

text \<open>
  We can now state, and prove, the property that @{term client} and
  @{term store} never directly communicate.
\<close>

lemma "\<forall>c.
  \<not>(communicates_on c client_untrusted \<and> communicates_on c store_untrusted)"
  unfolding communicates_on_def client_untrusted_def Client_untrusted_def
            store_untrusted_def Store_untrusted_def
  apply clarsimp
  unfolding UserStep_def ArbitraryRequest_def ArbitraryResponse_def
  apply clarsimp
  apply (case_tac c, clarsimp+)
  done

text \<open>
  Were we to try reasoning about a property of the system that depended upon
  the behaviour of any component in the system, we would not be able to do it
  using the existing definitions. To show a property of this form we need to
  provide a more precise definition of the critical components. An example of
  this is shown in the next section.
\<close>

(*<*)
(* Whether a component ever sends a question in a given set. *)
fun
  sends :: "component \<Rightarrow> channel question set \<Rightarrow> bool"
where
   "sends (Request f _) qs = (\<exists>s. \<exists>q \<in> f s. q \<in> qs)"
 | "sends (a ;; b) qs = (sends a qs \<or> sends b qs)"
 | "sends (IF cond THEN a ELSE b) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s \<and> sends b qs)"
 | "sends (WHILE cond DO a) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s)"
 | "sends (a \<squnion> b) qs = (sends a qs \<or> sends b qs)"
 | "sends _ _ = False"

text \<open>
  Reasoning about a property of the system execution itself is not possible
  because we have not described what the components themselves actually do. For
  example, proving that the client never reads the secret is not possible.
\<close>

lemma "\<forall>p. \<exists>e s. gs\<^sub>0 p = Some (e, s) \<and>
           (e = client_untrusted \<or>
            \<not>(\<exists>c. sends e {x. q_channel x = c \<and> q_data x = Return [String ''baz'']} \<and>
              receives_on c client_untrusted))"
  oops

end
(*>*)


theory Worklist_Subsumption_Impl1
  imports Refine_Imperative_HOL.IICF Worklist_Subsumption1
begin

  subsection \<open>Implementation on Lists\<close>

  (* XXX Duplication, see DBM_Operations_Impl *)
  lemma list_ex_foldli:
    "list_ex P xs = foldli xs Not (\<lambda> x y. P x \<or> y) False"
   apply (induction xs)
   apply (simp; fail)
   subgoal for x xs
    apply simp
    apply (induction xs)
   by auto
  done

  lemma list_filter_foldli:
    "[x \<leftarrow> xs. P x] = rev (foldli xs (\<lambda> x. True) (\<lambda> x xs. if P x then x # xs else xs) [])"
    (is "_ = rev (foldli xs ?c ?f [])")
  proof -
    have *:
      "rev (foldli xs ?c ?f (ys @ zs)) = rev zs @ rev (foldli xs ?c ?f ys)" for xs ys zs
    proof (induction xs arbitrary: ys)
      case Nil
      then show ?case by simp
    next
      case (Cons x xs)
      from Cons[of "x # ys"] Cons[of ys] show ?case by simp
    qed
    show ?thesis
      apply (induction xs)
       apply (simp; fail)
      apply simp
      apply (subst (2) *[of _ "[]", simplified])
      by simp
  qed

  (* XXX Move *)
  context notes [split!] = list.split begin
  sepref_decl_op list_hdtl: "\<lambda> (x # xs) \<Rightarrow> (x, xs)" :: "[\<lambda>l. l\<noteq>[]]\<^sub>f \<langle>A\<rangle>list_rel \<rightarrow> A \<times>\<^sub>r \<langle>A\<rangle>list_rel"
    by auto
  end

  context Worklist4_Impl
  begin
    sepref_register "PR_CONST a\<^sub>0" "PR_CONST F'" "PR_CONST (\<unlhd>)" "PR_CONST succs" "PR_CONST empty"

    (* XXX Now obsolete *)
    lemma take_from_mset_as_mop_mset_pick: "take_from_mset = mop_mset_pick"
      apply (intro ext)
      unfolding take_from_mset_def[abs_def]
      by (auto simp: pw_eq_iff refine_pw_simps)

    lemma take_from_list_alt_def:
      "take_from_list xs = do {_ \<leftarrow> ASSERT (xs \<noteq> []); RETURN (hd_tl xs)}"
      unfolding take_from_list_def by (auto simp: pw_eq_iff refine_pw_simps)

    lemma [safe_constraint_rules]: "CN_FALSE is_pure A \<Longrightarrow> is_pure A" by simp

    sepref_thm filter_insert_wait_impl is
      "uncurry (RETURN oo PR_CONST filter_insert_wait)" :: "(list_assn A)\<^sup>d *\<^sub>a A\<^sup>d \<rightarrow>\<^sub>a list_assn A"
      unfolding filter_insert_wait_alt_def list_ex_foldli list_filter_foldli
      unfolding HOL_list.fold_custom_empty
      unfolding PR_CONST_def
      by sepref

    concrete_definition (in -) filter_insert_wait_impl
      uses Worklist4_Impl.filter_insert_wait_impl.refine_raw is "(uncurry ?f, _) \<in> _"

    lemmas [sepref_fr_rules] = filter_insert_wait_impl.refine[OF Worklist4_Impl_axioms]

    sepref_register filter_insert_wait

    lemmas [sepref_fr_rules] = hd_tl_hnr

    sepref_thm worklist_algo2_impl is "uncurry0 worklist_algo2" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
      unfolding worklist_algo2_def worklist_algo2'_def add_succ2_alt_def PR_CONST_def
      supply [[goals_limit = 1]]
      supply conv_to_is_Nil[simp]
      apply (rewrite in "Let \<hole> _" lso_fold_custom_empty)
      unfolding fold_lso_bex
      unfolding take_from_list_alt_def
      apply (rewrite in "[a\<^sub>0]" HOL_list.fold_custom_empty)
      by sepref

    concrete_definition (in -) worklist_algo2_impl
    for Lei a\<^sub>0i Fi succsi emptyi
    uses Worklist4_Impl.worklist_algo2_impl.refine_raw is "(uncurry0 ?f,_)\<in>_"

    end \<comment> \<open>Worklist4 Impl\<close>

  context Worklist4_Impl_finite_strict
    begin

    lemma worklist_algo2_impl_hnr_F_reachable:
      "(uncurry0 (worklist_algo2_impl Lei a\<^sub>0i Fi succsi emptyi), uncurry0 (RETURN F_reachable))
      \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
      using worklist_algo2_impl.refine[OF Worklist4_Impl_axioms,
        FCOMP worklist_algo2_ref[THEN nres_relI],
        FCOMP worklist_algo''_correct[THEN Id_SPEC_refine, THEN nres_relI]]
      by (simp add: RETURN_def)

    sepref_decl_op F_reachable :: "bool_rel" .
    lemma [def_pat_rules]: "F_reachable \<equiv> op_F_reachable" by simp

    lemma hnr_op_F_reachable:
      assumes "GEN_ALGO a\<^sub>0i (\<lambda>a\<^sub>0i. (uncurry0 a\<^sub>0i, uncurry0 (RETURN a\<^sub>0)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a A)"
      assumes "GEN_ALGO Fi (\<lambda>Fi. (Fi,RETURN o F') \<in> A\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
      assumes "GEN_ALGO Lei (\<lambda>Lei. (uncurry Lei,uncurry (RETURN oo (\<unlhd>))) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
      assumes "GEN_ALGO succsi (\<lambda>succsi. (succsi,RETURN o succs) \<in> A\<^sup>k \<rightarrow>\<^sub>a list_assn A)"
      assumes "GEN_ALGO emptyi (\<lambda>Fi. (Fi,RETURN o empty) \<in> A\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
      shows
        "(uncurry0 (worklist_algo2_impl Lei a\<^sub>0i Fi succsi emptyi), uncurry0 (RETURN (PR_CONST op_F_reachable)))
        \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    proof -
      from assms interpret Worklist4_Impl E a\<^sub>0 F "(\<preceq>)" succs empty "(\<unlhd>)" F' A succsi a\<^sub>0i Fi Lei emptyi
        by (unfold_locales; simp add: GEN_ALGO_def)

      from worklist_algo2_impl_hnr_F_reachable show ?thesis by simp
    qed

    sepref_decl_impl hnr_op_F_reachable .

  end \<comment> \<open>Worklist4 (strictly finite)\<close>

end \<comment> \<open>End of Theory\<close>


theory op_tee_init
imports "Op_Tee_Def" "Op_Tee_Spec" "../State_Machine"

begin

section"The sys instantiation of state machine"

consts sys_conf :: "Sys_Conf"

definition sys_config_witness :: "Sys_Conf"
  where "sys_config_witness \<equiv>
  \<lparr> kerneler_conf = undefined,
    cpus_conf={},
    procs_conf =Map.empty,
    objs_conf = Map.empty \<rparr>"

specification(sys_conf)
  proc_not_kernel: "(procs_conf sys_conf) x \<noteq> None
                    \<Longrightarrow> x \<noteq> kerneler_conf sys_conf"
  kernel_not_proc: "kerneler_conf sys_conf = x
                    \<Longrightarrow> (procs_conf sys_conf) x = None"
  domainid_eq_pid: "\<forall> p. (procs_conf sys_conf) p \<noteq> None
                    \<longrightarrow> subjid_name(subjattr_procid(proc_subattr_conf(the((procs_conf sys_conf) p))))  = p"
proof-
  have p1: "\<exists> f n na .f (n::nat) = (None::Proc_Conf option) \<and> f na = None \<and> na \<noteq> n"
    by fastforce
  have p2: "\<exists> sys_conf .(\<forall> p. (procs_conf sys_conf) p \<noteq> None
                    \<longrightarrow> subjid_name(subjattr_procid(proc_subattr_conf(the((procs_conf sys_conf) p))))  = p)"
    using sys_config_witness_def
    by (metis Sys_Conf.select_convs(3))
  show ?thesis
    using sys_config_witness_def p1 p2
  proof -
    show ?thesis
      by (metis Sys_Conf.select_convs(1) Sys_Conf.select_convs(3) sys_config_witness_def)
  qed
qed

definition sys_init :: "Sys_Conf \<Rightarrow> Sys_State"
  where"sys_init sc \<equiv> \<lparr>
                        currents = Map.empty,
                        objs = Map.empty,
                        procs = Map.empty,
                        memories = {},
                        mode = (TEE Privilege)
                       \<rparr>"

consts fn_s0 :: Sys_State

definition "fn_s0_witness \<equiv> sys_init sys_conf"

specification(fn_s0)
  fn_s0_init: "fn_s0 = fn_s0_witness"
  by simp

definition fn_step :: "Event \<Rightarrow> (Sys_State\<times> Sys_State) set"
  where"fn_step event = {(s,s'). s' \<in>
  (case
    event
   of
    sys_call (TEE_OBJ_CREATE sc poa) pa \<Rightarrow>
                            {fst(utee_obj_create s sc pa poa)} |
    sys_call (TEE_OBJ_COPY poa r) pa \<Rightarrow>
                            {fst(utee_obj_copy s pa poa r)} |
    sys_call (TEE_OBJ_CLOSE poa) pa \<Rightarrow>
                            {fst(utee_obj_close s pa poa)} |
    sys_call (TEE_OBJ_DEL poa) pa \<Rightarrow>
                            {fst(utee_obj_del s pa poa)} |
    sys_call (TEE_OBJ_TRANS dst_pa channel_poa trans_poa) src_pa \<Rightarrow>
                            {fst(utee_channel_transmit s src_pa dst_pa channel_poa trans_poa)}|
    kernel_event (TEE_OBJ_DEBUG poa) pa \<Rightarrow>
                            {fst(mbedtls_debug_print_buf s pa poa)})}"

(*get the domain*)
definition fn_dom :: "Sys_State \<Rightarrow> Event \<Rightarrow> Pid option"
  where "fn_dom s e \<equiv>
  case
    e
  of
    sys_call _ poa \<Rightarrow> Some(subjid_name(subjattr_procid(poa)))"

definition equiv_object :: "Sys_State \<Rightarrow> Kid \<Rightarrow> Sys_State \<Rightarrow> bool"
  where "equiv_object s kid t \<equiv>
  kernel_objs s kid = kernel_objs t kid"

definition equiv_handle:: "Sys_State \<Rightarrow> Pid \<Rightarrow> Sys_State \<Rightarrow> bool"
  where "equiv_handle s pid t \<equiv>
  \<forall> hid . proc_handles(the(procs s pid)) hid = proc_handles(the(procs t pid)) hid \<and>
          equiv_object s (kernel_obj_id(the(proc_handles(the(procs s pid)) hid))) t"

definition equiv_proc :: "Sys_State \<Rightarrow> Pid \<Rightarrow> Sys_State \<Rightarrow> bool"
  where "equiv_proc s pid t \<equiv>
  procs s pid = procs t pid \<and> equiv_handle s pid t"

definition fn_equiv :: "Sys_State \<Rightarrow> Pid \<Rightarrow> Sys_State \<Rightarrow> bool" ("(_~_~_)")
  where "fn_equiv s pid t \<equiv>
  if
    is_proc sys_conf pid
  then
    equiv_proc s pid t
  else if
    is_kernel sys_conf pid
  then
    True
  else
    False"

definition fn_interfence :: "Pid \<Rightarrow> Pid \<Rightarrow> bool" ("(_ \<leadsto> _)")
  where "fn_interfence d1 d2 \<equiv>
  if
    d1 = d2
  then
    True
  else if
    is_kernel sys_conf d1
  then
    True
  else
    False"

definition fn_non_interference :: "Pid \<Rightarrow> Pid \<Rightarrow> bool" ("(_ \<setminus>\<leadsto> _)")
  where "(u \<setminus>\<leadsto>  v) \<equiv> \<not> (u \<leadsto> v)"

declare equiv_object_def[cong] and equiv_handle_def[cong] and equiv_proc_def[cong] and
        fn_equiv_def[cong] fn_interfence_def[cong] fn_non_interference_def[cong] and fn_dom_def[cong]

lemma equiv_proc_transitive :
  "\<forall> s t r d. equiv_proc s d t \<and> equiv_proc t d r
              \<longrightarrow> equiv_proc s d r"
   by auto

lemma equiv_proc_symmetic :
  "\<forall> s t d. equiv_proc s d t
            \<longrightarrow> equiv_proc t d s"
  by auto

lemma equiv_proc_reflexive :
  "\<forall> s d. equiv_proc s d s"
  by auto

lemma fn_equiv_relfexive:
  "\<forall> s d . fn_equiv s d s"
  using equiv_proc_reflexive try0
lemma fn_kernel_intf_all :
  "\<forall> d. fn_interfence (kerneler_conf sys_conf) d"
  by (simp add: is_kernel_def)

lemma fn_not_intf_kernel :
  "\<forall> d. fn_interfence d (kerneler_conf sys_conf) \<longrightarrow>
        d = (kerneler_conf sys_conf)"
  by (simp add: is_kernel_def)

lemma fn_intf_reflexive: "fn_interfence d d"
  by auto

lemma fn_reachable:
  "\<forall> s a. (SM.reachable0 fn_s0 fn_step) s \<longrightarrow>
          (\<exists> s'. (s,s') \<in> fn_step a)"
proof -
  {
    fix s a
    assume p0: "(SM.reachable0 fn_s0 fn_step) s"
    have "\<exists> s' .(s,s') \<in> fn_step a"
    proof(induct a)
      case (sys_call x1 x2)
      then show ?case
        apply(induct x1)
        by (simp add:fn_step_def)+
    next
      case (kernel_event x1 x2)
      then show ?case
        apply (induct x1)
      by (simp add:fn_step_def)+
    qed
  }
  then show ?thesis by simp
qed

interpretation SM_enabled
        fn_s0 fn_step fn_dom  "kerneler_conf sys_conf" fn_equiv fn_interfence
  using fn_reachable fn_kernel_intf_all fn_not_intf_kernel equiv_proc_reflexive
        equiv_proc_transitive equiv_proc_symmetic fn_intf_reflexive
end


theory Defs
  imports "HOL-IMP.AExp" "HOL-IMP.BExp"
begin

fun deduplicate :: "'a list \<Rightarrow> 'a list" where
  "deduplicate [] = []"
| "deduplicate [x] = [x]"
| "deduplicate (x # y # xs) = (if x = y then deduplicate (y # xs) else x # deduplicate (y # xs))"

lemma "length (deduplicate xs) \<le> length xs"
  by (induction xs rule: deduplicate.induct) auto

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst x a' (N n) = N n"
| "subst x a' (V y) = (if x=y then a' else V y)"
| "subst x a' (Plus a1 a2) = Plus (subst x a' a1) (subst x a' a2)"

lemma subst_lemma: "aval (subst x a' a) s = aval a (s(x:=aval a' s))"
  by (induct a) auto

lemma comp: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 a) s = aval (subst x a2 a) s"
  by (simp add: subst_lemma)

datatype aexp' = N' int | V' vname | PI' vname | Plus' aexp' aexp'

fun aval' where
  "aval' (N' n) s = (n,s)" |
  "aval' (V' x) s = (s x, s)" |
  "aval' (PI' x) s = (s x, s(x := 1 + s x))" |
  "aval' (Plus' a1 a2) s = (
    let (v1, s') = aval' a1 s; (v2, s'') = aval' a2 s'
    in (v1 + v2, s''))"

lemma "aval' (Plus' (PI' x) (V' x)) <> \<noteq> aval' (Plus' (V' x) (PI' x)) <>"
  by auto

lemma aval'_inc': "aval' a s = (v,s') \<Longrightarrow> s x \<le> s' x"
  apply (induct a arbitrary: s s' v)
     apply (auto split: prod.splits)
  apply fastforce
  done

lemma aval'_inc:
  "aval' a <> = (v, s') \<Longrightarrow> 0 \<le> s' x"
  using aval'_inc' by (fastforce simp: null_state_def)

end


theory ValueOntologyTest     (*Benzmüller, Fuenmayor & Lomfeld, 2020*)
  imports ValueOntologyNew
begin

(*exploring the consistency and models of the ontology*)
lemma "True" nitpick[satisfy,show_all,card i=1] oops
lemma "True" nitpick[satisfy,show_all,card i=10] oops

lemma "\<lfloor>INCONS\<^sup>p\<rfloor>" nitpick[satisfy,card i=4] nitpick oops (*contingent*)
lemma "\<lfloor>INDIFF\<^sup>p\<rfloor>" nitpick[satisfy,card i=4] nitpick oops (*contingent*)

(****the pair of Ext/Int operators satisfies the main properties of Galois connections ****)
lemma G:  "B \<^bold>\<sqsubseteq> A\<up> \<longleftrightarrow> A \<^bold>\<sqsubseteq> B\<down>" by blast

lemma G1:      "A \<^bold>\<sqsubseteq> A\<up>\<down>" by simp
lemma G2:      "B \<^bold>\<sqsubseteq> B\<down>\<up>" by simp
lemma G3:     "A\<^sub>1 \<^bold>\<sqsubseteq> A\<^sub>2 \<longrightarrow> A\<^sub>2\<up> \<^bold>\<sqsubseteq> A\<^sub>1\<up>" by simp
lemma G4:     "B\<^sub>1 \<^bold>\<sqsubseteq> B\<^sub>2 \<longrightarrow> B\<^sub>2\<down> \<^bold>\<sqsubseteq> B\<^sub>1\<down>" by simp

lemma cl1:    "A\<up> = A\<up>\<down>\<up>" by blast
lemma cl2:    "B\<down> = B\<down>\<up>\<down>" by blast
lemma dual1a: "(A\<^sub>1 \<^bold>\<squnion> A\<^sub>2)\<up> = (A\<^sub>1\<up> \<^bold>\<sqinter> A\<^sub>2\<up>)" by blast
lemma dual1b: "(B\<^sub>1 \<^bold>\<squnion> B\<^sub>2)\<down> = (B\<^sub>1\<down> \<^bold>\<sqinter> B\<^sub>2\<down>)" by blast

lemma          "(A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up> \<^bold>\<sqsubseteq> (A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>)" nitpick oops
lemma          "(B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down> \<^bold>\<sqsubseteq> (B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>)" nitpick oops
lemma dual2a: "(A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>) \<^bold>\<sqsubseteq>  (A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up>" by blast
lemma dual2b: "(B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>) \<^bold>\<sqsubseteq>  (B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down>" by blast

(***** test notation **)
lemma "(let y = x\<inverse> in WILL\<^sup>y) = WILL\<^sup>x\<inverse>" by meson
(*both notations do the same. TODO: do we want to do away with rhs?*)
lemma "\<lfloor>[WILL\<^sup>x\<oplus>STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor> \<equiv> \<lfloor>(WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x)\<down> \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp

(********* value ontology tests *****************)
lemma "SECU\<^sup>x \<^bold>\<sqsubseteq> RELI\<^sup>x" by simp
lemma "RELI\<^sup>x\<down> \<^bold>\<sqsubseteq> SECU\<^sup>x\<down>" by simp
lemma "\<lfloor>RELI\<^sup>x\<down> \<^bold>\<rightarrow> SECU\<^sup>x\<down>\<rfloor>" by simp
lemma "EQUA\<^sup>x \<^bold>\<sqsubseteq> RELI\<^sup>x" by simp
lemma "RELI\<^sup>x\<down> \<^bold>\<sqsubseteq> EQUA\<^sup>x\<down>" by simp
lemma "\<lfloor>RELI\<^sup>x\<down> \<^bold>\<rightarrow> EQUA\<^sup>x\<down>\<rfloor>" by simp
lemma "\<lfloor>RELI\<^sup>x\<down> \<^bold>\<rightarrow> (SECU\<^sup>x\<down> \<^bold>\<and> EQUA\<^sup>x\<down>)\<rfloor>" by simp

lemma "\<lfloor>RELI\<^sup>p\<down> \<^bold>\<and> WILL\<^sup>p\<down> \<^bold>\<rightarrow> INCONS\<^sup>p\<rfloor>" by simp
lemma "\<lfloor>INCONS\<^sup>p \<^bold>\<rightarrow> RELI\<^sup>p\<down> \<^bold>\<and> WILL\<^sup>p\<down>\<rfloor>" by simp

lemma "\<lfloor>RELI\<^sup>p\<down> \<^bold>\<and> WILL\<^sup>p\<down>\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>FAIR\<^sup>d\<down> \<^bold>\<and> EFFI\<^sup>d\<down>\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(\<^bold>\<not>INCONS\<^sup>p) \<^bold>\<and> [FAIR\<^sup>d] \<^bold>\<and> [EFFI\<^sup>d]\<rfloor>"
   nitpick[satisfy,show_all] nitpick oops (*contingent: p & d are independent*)
lemma "\<lfloor>(\<^bold>\<not>INCONS\<^sup>d) \<^bold>\<and> (\<^bold>\<not>INCONS\<^sup>p) \<^bold>\<and> [RELI\<^sup>d] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>"
  nitpick[satisfy,show_all] nitpick oops (*contingent: p & d are independent*)

(*more tests*)
lemma "\<lfloor>[WILL\<^sup>x\<oplus>STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*two non-opposed quadrants \<oplus> (noq): consistent*)
lemma "\<lfloor>WILL\<^sup>x\<down> \<^bold>\<and> STAB\<^sup>x\<down> \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*two non-opposed quadrants \<and> (noq): consistent*)

lemma "\<lfloor>[WILL\<^sup>x\<oplus>GAIN\<^sup>X\<oplus>EFFI\<^sup>x\<oplus>STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*two noq \<oplus>: consistent*)
lemma "\<lfloor>WILL\<^sup>x\<down> \<^bold>\<and> GAIN\<^sup>X\<down> \<^bold>\<and> EFFI\<^sup>x\<down> \<^bold>\<and> STAB\<^sup>x\<down> \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*two noq \<and>: consistent*)

lemma "\<lfloor>[WILL\<^sup>x\<oplus>EFFI\<^sup>x\<oplus>RELI\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*three quadrants \<oplus>: consistent*)
lemma "\<lfloor>WILL\<^sup>x\<down> \<^bold>\<and> EFFI\<^sup>x\<down> \<^bold>\<and> RELI\<^sup>x\<down> \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp (*three quadrants \<and>: inconsistent*)

lemma "\<lfloor>[RESP\<^sup>x\<oplus>STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*two opposed quadrants \<oplus> (oq): consistent*)
lemma "\<lfloor>RESP\<^sup>x\<down> \<^bold>\<and> STAB\<^sup>x\<down> \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp (*two opposed quadrants \<and> (oq): inconsistent*)

lemma "\<lfloor>[EQUI\<^sup>x\<oplus>EFFI\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*two noq (different parties) \<oplus>: consistent*)
lemma "\<lfloor>EQUI\<^sup>x\<down> \<^bold>\<and> EFFI\<^sup>y\<down> \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*two noq (different parties) \<and>: consistent*)

lemma "\<lfloor>[RESP\<^sup>x\<oplus>STAB\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*two oq (different parties) \<oplus>: consistent*)
lemma "\<lfloor>RESP\<^sup>x\<down> \<^bold>\<and> STAB\<^sup>y\<down> \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*two oq (different parties) \<and>: consistent*)

(* value preferences tests*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>" by blast
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>" by blast
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<not>\<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" using rBR by auto
lemma "\<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" by auto
lemma "\<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" by auto
lemma "\<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)

end


theory utp_hoare
imports utp_rel_laws
begin

text \<open>Hoare triples\<close>

definition hoare_r :: "('s \<Rightarrow> bool) \<Rightarrow> 's hrel \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" where
[pred]: "hoare_r p Q r = ((p\<^sup>< \<longrightarrow> r\<^sup>>)\<^sub>e \<sqsubseteq> Q)"

syntax
  "_hoare_r" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>{_\<^bold>}/ _/ \<^bold>{_\<^bold>}")
  "_hoare_r" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("H{_}/ _/ {_}")

translations "_hoare_r P S Q" == "CONST hoare_r (P)\<^sub>e S (Q)\<^sub>e"

named_theorems hoare and hoare_safe

lemma hoare_meaning: "H{p}Q{r} = (\<forall> s s'. p s \<and> Q (s, s') \<longrightarrow> r s')"
  by (pred_auto)

lemma hoare_alt_def: "\<^bold>{b\<^bold>}P\<^bold>{c\<^bold>} = (P ;; \<questiondown>c? \<sqsubseteq> \<questiondown>b? ;; P)"
  by (pred_auto)

lemma hoare_assume: "\<^bold>{P\<^bold>}S\<^bold>{Q\<^bold>} \<Longrightarrow> \<questiondown>P? ;; S = \<questiondown>P? ;; S ;; \<questiondown>Q?"
  by (pred_auto)

lemma hoare_pre_assume_1: "\<^bold>{b \<and> c\<^bold>}P\<^bold>{d\<^bold>} = \<^bold>{c\<^bold>}\<questiondown>b? ;; P\<^bold>{d\<^bold>}"
  by (pred_auto)

lemma hoare_pre_assume_2: "\<^bold>{b \<and> c\<^bold>}P\<^bold>{d\<^bold>} = \<^bold>{b\<^bold>}\<questiondown>c? ;; P\<^bold>{d\<^bold>}"
  by pred_auto

lemma hoare_test [hoare_safe]: "`p \<and> b \<longrightarrow> q` \<Longrightarrow> \<^bold>{p\<^bold>}\<questiondown>b?\<^bold>{q\<^bold>}"
  by pred_auto

lemma hoare_gcmd [hoare_safe]: "\<^bold>{p \<and> b\<^bold>}P\<^bold>{q\<^bold>} \<Longrightarrow> \<^bold>{p\<^bold>}\<questiondown>b? ;; P\<^bold>{q\<^bold>}"
  by pred_auto

lemma hoare_r_conj [hoare_safe]: "\<lbrakk> \<^bold>{p\<^bold>}Q\<^bold>{r\<^bold>}; \<^bold>{p\<^bold>}Q\<^bold>{s\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}Q\<^bold>{r \<and> s\<^bold>}"
  by pred_auto

lemma hoare_r_weaken_pre [hoare]:
  "\<^bold>{p\<^bold>}Q\<^bold>{r\<^bold>} \<Longrightarrow> \<^bold>{p \<and> q\<^bold>}Q\<^bold>{r\<^bold>}"
  "\<^bold>{q\<^bold>}Q\<^bold>{r\<^bold>} \<Longrightarrow> \<^bold>{p \<and> q\<^bold>}Q\<^bold>{r\<^bold>}"
  by pred_auto+

lemma hoare_r_conseq: "\<lbrakk> \<^bold>{p\<^sub>2\<^bold>}S\<^bold>{q\<^sub>2\<^bold>}; `p\<^sub>1 \<longrightarrow> p\<^sub>2`; `q\<^sub>2 \<longrightarrow> q\<^sub>1` \<rbrakk> \<Longrightarrow> \<^bold>{p\<^sub>1\<^bold>}S\<^bold>{q\<^sub>1\<^bold>}"
  by pred_auto

lemma hoare_r_cut:
  assumes "\<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}" "\<^bold>{b \<and> c\<^bold>}P\<^bold>{c\<^bold>}"
  shows "\<^bold>{b \<and> c\<^bold>}P\<^bold>{b \<and> c\<^bold>}"
  using assms by pred_auto

lemma hoare_r_cut_simple:
  assumes "\<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}" "\<^bold>{c\<^bold>}P\<^bold>{c\<^bold>}"
  shows "\<^bold>{b \<and> c\<^bold>}P\<^bold>{b \<and> c\<^bold>}"
  using assms by pred_auto

lemma hoare_oracle: "\<^bold>{p\<^bold>}false\<^bold>{q\<^bold>}"
  by (simp add: hoare_r_def)

subsection \<open> Sequence Laws \<close>

lemma seq_hoare_r: "\<lbrakk> \<^bold>{p\<^bold>}Q\<^sub>1\<^bold>{s\<^bold>} ; \<^bold>{s\<^bold>}Q\<^sub>2\<^bold>{r\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{r\<^bold>}"
  by (pred_auto)

lemma seq_hoare_invariant [hoare_safe]: "\<lbrakk> \<^bold>{p\<^bold>}Q\<^sub>1\<^bold>{p\<^bold>} ; \<^bold>{p\<^bold>}Q\<^sub>2\<^bold>{p\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{p\<^bold>}"
  by (pred_auto)

lemma seq_hoare_stronger_pre_1 [hoare_safe]:
  "\<lbrakk> \<^bold>{p \<and> q\<^bold>}Q\<^sub>1\<^bold>{p \<and> q\<^bold>} ; \<^bold>{p \<and> q\<^bold>}Q\<^sub>2\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p \<and> q\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{q\<^bold>}"
  using seq_hoare_r by blast

lemma seq_hoare_stronger_pre_2 [hoare_safe]:
  "\<lbrakk> \<^bold>{p \<and> q\<^bold>}Q\<^sub>1\<^bold>{p \<and> q\<^bold>} ; \<^bold>{p \<and> q\<^bold>}Q\<^sub>2\<^bold>{p\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p \<and> q\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{p\<^bold>}"
  using seq_hoare_r by blast

lemma seq_hoare_inv_r_2 [hoare]: "\<lbrakk> \<^bold>{p\<^bold>}Q\<^sub>1\<^bold>{q\<^bold>} ; \<^bold>{q\<^bold>}Q\<^sub>2\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{q\<^bold>}"
  using seq_hoare_r by blast

lemma seq_hoare_inv_r_3 [hoare]: "\<lbrakk> \<^bold>{p\<^bold>}Q\<^sub>1\<^bold>{p\<^bold>} ; \<^bold>{p\<^bold>}Q\<^sub>2\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}Q\<^sub>1 ;; Q\<^sub>2\<^bold>{q\<^bold>}"
  using seq_hoare_r by blast

subsection \<open> Assignment Laws \<close>

lemma assigns_hoare_r [hoare_safe]: "`p \<longrightarrow> \<sigma> \<dagger> q` \<Longrightarrow> \<^bold>{p\<^bold>}\<langle>\<sigma>\<rangle>\<^sub>a\<^bold>{q\<^bold>}"
  by pred_auto

lemma assigns_backward_hoare_r:
  "\<^bold>{\<sigma> \<dagger> p\<^bold>}\<langle>\<sigma>\<rangle>\<^sub>a\<^bold>{p\<^bold>}"
  by pred_auto

lemma assigns_init_hoare [hoare_safe]:
  "\<lbrakk> vwb_lens x; $x \<sharp> p; $x \<sharp> v; \<^bold>{$x = v \<and> p\<^bold>}S\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}(x := v) ;; S\<^bold>{q\<^bold>}"
  by pred_auto

lemma assigns_init_hoare_general:
  "\<lbrakk> vwb_lens x; \<And> x\<^sub>0. \<^bold>{$x = v\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/x\<rbrakk> \<and> p\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/x\<rbrakk>\<^bold>}S\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}x := v ;; S\<^bold>{q\<^bold>}"
  by (rule seq_hoare_r, rule assign_floyd_hoare_r, simp, pred_auto)

lemma assigns_final_hoare [hoare_safe]:
  "\<^bold>{p\<^bold>}S\<^bold>{\<sigma> \<dagger> q\<^bold>} \<Longrightarrow> \<^bold>{p\<^bold>}S ;; \<langle>\<sigma>\<rangle>\<^sub>a\<^bold>{q\<^bold>}"
  by (pred_auto)

lemma skip_hoare_r [hoare_safe]: "\<^bold>{p\<^bold>}II\<^bold>{p\<^bold>}"
  by pred_auto

lemma skip_hoare_impl_r [hoare_safe]: "`p \<longrightarrow> q` \<Longrightarrow> \<^bold>{p\<^bold>}II\<^bold>{q\<^bold>}"
  by pred_auto

subsection \<open> Conditional Laws \<close>

lemma cond_hoare_r [hoare_safe]: "\<lbrakk> \<^bold>{b \<and> p\<^bold>}S\<^bold>{q\<^bold>} ; \<^bold>{\<not>b \<and> p\<^bold>}T\<^bold>{q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{p\<^bold>}S \<lhd> b \<rhd> T\<^bold>{q\<^bold>}"
  by pred_auto

lemma cond_hoare_r_wp:
  assumes "\<^bold>{p'\<^bold>}S\<^bold>{q\<^bold>}" and "\<^bold>{p''\<^bold>}T\<^bold>{q\<^bold>}"
  shows "\<^bold>{(b \<and> p') \<sqinter> (\<not>b \<and> p'')\<^bold>} S \<lhd> b \<rhd> T \<^bold>{q\<^bold>}"
  using assms by pred_auto

lemma cond_hoare_r_sp:
  assumes "\<^bold>{(b \<and> p)\<^bold>}S\<^bold>{q\<^bold>}" and "\<^bold>{\<not>b \<and> p\<^bold>}T\<^bold>{s\<^bold>}"
  shows "\<^bold>{p\<^bold>}S \<lhd> b \<rhd> T\<^bold>{q \<or> s\<^bold>}"
  using assms by pred_auto

lemma hoare_ndet [hoare_safe]:
  assumes "\<^bold>{p\<^bold>}P\<^bold>{q\<^bold>}" "\<^bold>{p\<^bold>}Q\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}(P \<sqinter> Q)\<^bold>{q\<^bold>}"
  using assms by (pred_auto)

lemma hoare_disj [hoare_safe]:
  assumes "\<^bold>{p\<^bold>}P\<^bold>{q\<^bold>}" "\<^bold>{p\<^bold>}Q\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}(P \<sqinter> Q)\<^bold>{q\<^bold>}"
  using assms by (pred_auto)

lemma hoare_UINF [hoare_safe]:
  assumes "\<And>i. i \<in> A \<Longrightarrow> \<^bold>{p\<^bold>}P(i)\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}(\<Sqinter> {P(i)|i. i\<in>A})\<^bold>{q\<^bold>}"
  by (pred_auto assms: assms)

subsection \<open> Recursion Laws \<close>

lemma nu_hoare_r_partial:
  assumes induct_step: "\<And>P st. \<^bold>{p\<^bold>}P\<^bold>{q\<^bold>} \<Longrightarrow> \<^bold>{p\<^bold>}F P\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}\<nu> F\<^bold>{q\<^bold>}"
  using assms
  unfolding hoare_r_def pred_ref_iff_le
  by (rule lfp_lowerbound, pred_auto)

(*
lemma mu_hoare_r:
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<Sqinter> st P. \<^bold>{p \<and> (e,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<^bold>}P\<^bold>{q\<^bold>} \<Longrightarrow> \<^bold>{p \<and> e = \<guillemotleft>st\<guillemotright>\<^bold>}F P\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}\<mu> F \<^bold>{q\<^bold>}"
  unfolding hoare_r_def
proof (rule mu_rec_total_utp_rule[OF WF M , of _ e ], goal_cases)
  case (1 st)
  then show ?case
    using induct_step[unfolded hoare_r_def, of st "(p\<^sup>< \<and> (e\<^sup><, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q\<^sup>>)\<^sub>u"]
      by (simp add: usubst)
qed
    \<Sqinter>
lemma mu_hoare_r':
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<Sqinter> st P. \<^bold>{p \<and> (e,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<^bold>} P \<^bold>{q\<^bold>} \<Longrightarrow> \<^bold>{p \<and> e = \<guillemotleft>st\<guillemotright>\<^bold>} F P \<^bold>{q\<^bold>}"
  assumes I0: "`p' \<longrightarrow> p`"
  shows "\<^bold>{p'\<^bold>} \<mu> F \<^bold>{q\<^bold>}"
  using I0 M WF assms(3) mu_hoare_r pre_str_hoare_r by blast
*)
subsection \<open> Iteration Rules \<close>

(*
lemma iter_hoare_r [hoare_safe]: "\<^bold>{P\<^bold>}S\<^bold>{P\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>}S\<^sup>\<star>\<^bold>{P\<^bold>}"
   using rtrancl_induct by (pred_auto, fastforce)
*)

lemma while_hoare_r [hoare_safe]:
  assumes "\<^bold>{p \<and> b\<^bold>}S\<^bold>{p\<^bold>}"
  shows "\<^bold>{p\<^bold>}while b do S od\<^bold>{\<not>b \<and> p\<^bold>}"
proof (simp add: while_top_def hoare_r_def assms)
  have "(p\<^sup>< \<longrightarrow> (\<not> b \<and> p)\<^sup>>)\<^sub>e \<sqsubseteq> S ;; (p\<^sup>< \<longrightarrow> (\<not> b \<and> p)\<^sup>>)\<^sub>e \<lhd> b \<rhd> II"
    using assms by pred_auto
  then show "(p\<^sup>< \<longrightarrow> (\<not> b \<and> p)\<^sup>>)\<^sub>e \<sqsubseteq> (\<nu> X \<bullet> S ;; X \<lhd> b \<rhd> II)"
    by (simp add: pred_ref_iff_le lfp_lowerbound)
qed

lemma while_invr_hoare_r [hoare_safe]:
  assumes "\<^bold>{p \<and> b\<^bold>}S\<^bold>{p\<^bold>}" "`pre' \<longrightarrow> p`" "`(\<not>b \<and> p) \<longrightarrow> post'`"
  shows "\<^bold>{pre'\<^bold>}while b invr p do S od\<^bold>{post'\<^bold>}"
  unfolding while_inv_def using assms while_hoare_r hoare_r_conseq by blast

lemma while_r_minimal_partial:
  assumes seq_step: "`p \<longrightarrow> invar`"
  assumes induct_step: "\<^bold>{invar \<and> b\<^bold>} C \<^bold>{invar\<^bold>}"
  shows "\<^bold>{p\<^bold>}while b do C od\<^bold>{\<not>b \<and> invar\<^bold>}"
  using induct_step pre_str_hoare_r seq_step while_hoare_r by blast

(*lemma approx_chain:
  "(\<Sqinter>n::nat. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><) = \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)*)

text \<open> Total correctness law for Hoare logic, based on constructive chains. This is limited to
  variants that have naturals numbers as their range. \<close>

lemma while_term_hoare_r:
  assumes "\<And> z::nat. \<^bold>{p \<and> b \<and> v = \<guillemotleft>z\<guillemotright>\<^bold>}S\<^bold>{p \<and> v < \<guillemotleft>z\<guillemotright>\<^bold>}"
  shows "\<^bold>{p\<^bold>}while\<^sub>\<bottom> b do S od\<^bold>{\<not>b \<and> p\<^bold>}"
proof -
  have "((p\<^sup><)\<^sub>e \<longrightarrow> ((\<not> b \<and> p)\<^sup>>)\<^sub>e) \<sqsubseteq> (\<mu> X \<bullet> S ;; X \<lhd> b \<rhd> II)"
  proof (rule mu_refine_intro)
    from assms show "((p\<^sup><)\<^sub>e \<longrightarrow> ((\<not> b \<and> p)\<^sup>>)\<^sub>e) \<sqsubseteq> S ;; ((p\<^sup><)\<^sub>e \<longrightarrow> ((\<not> b \<and> p)\<^sup>>)\<^sub>e) \<lhd> b \<rhd> II"
      by (pred_auto; smt (z3) hoare_meaning)+
    let ?E = "\<lambda> n. ((p \<and> v < \<guillemotleft>n\<guillemotright>)\<^sup><)\<^sub>e"
    show "((p\<^sup><)\<^sub>e \<and> (\<mu> X \<bullet> S ;; X \<lhd> b \<rhd> II)) = ((p\<^sup><)\<^sub>e \<and> (\<nu> X \<bullet> S ;; X \<lhd> b \<rhd> II))"
    proof (rule constr_fp_uniq[where E="?E"])
      show "mono (\<lambda>X. S ;; X \<lhd> b \<rhd> II)"
        by (rule cond_seqr_mono)
      show "constr (\<lambda>X. S ;; X \<lhd> b \<rhd> II) ?E"
        apply (rule constrI, rule chainI)
          apply (pred_auto, pred_auto, pred_auto)
        by (smt (verit, del_insts) assms hoare_meaning less_Suc_eq order_less_trans)+
    qed pred_auto (* Couldn't pattern match last goal *)
  qed
  thus ?thesis
    by (simp add: SEXP_def while_bot_def hoare_r_def impl_pred_def)
qed

lemma while_vrt_hoare_r [hoare_safe]:
  assumes "\<And> z::nat. \<^bold>{p \<and> b \<and> v = \<guillemotleft>z\<guillemotright>\<^bold>}S\<^bold>{p \<and> v < \<guillemotleft>z\<guillemotright>\<^bold>}" "`p' \<longrightarrow> p`" "`(\<not>b \<and> p) \<longrightarrow> q'`"
  shows "\<^bold>{p'\<^bold>}while b invr p vrt v do S od\<^bold>{q'\<^bold>}"
  apply (rule hoare_r_conseq[OF _ assms(2) assms(3)])
  apply (simp add: while_vrt_def)
  apply (rule while_term_hoare_r[where v="v", OF assms(1)])
  done

text \<open> General total correctness law based on well-founded induction \<close>

(*
lemma while_wf_hoare_r:
  assumes WF: "wf R"
  assumes I0: "`p' \<longrightarrow> p`"
  assumes induct_step:"\<And> st. \<^bold>{b \<and> p \<and> e = \<guillemotleft>st\<guillemotright>\<^bold>}Q\<^bold>{p \<and> (e, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<^bold>}"
  assumes PHI:"`(\<not>b \<and> p) \<longrightarrow> q'`"
  shows "\<^bold>{p'\<^bold>}while\<^sub>\<bottom> b invr p do Q od\<^bold>{q'\<^bold>}"
  unfolding hoare_r_def while_inv_bot_def while_bot_def
proof (rule pre_weak_rel[of _ "p\<^sup><" ], goal_cases)
  case 1
  from I0 show ?case by expr_auto
next
  case 2
  have "(p\<^sup>< \<longrightarrow> q'\<^sup>>)\<^sub>u \<sqsubseteq> (\<mu> X \<bullet> Q ;; X \<lhd> b \<rhd> II)"
  proof (rule mu_rec_total_utp_rule[where e=e, OF WF])
    show "mono (\<lambda>X. Q ;; X \<lhd> b \<rhd> II)"
      by (simp add: cond_seqr_mono)
    have induct_step': "\<Sqinter> st. ((b \<and> p \<and> e = \<guillemotleft>st\<guillemotright>)\<^sup>< \<longrightarrow> (p \<and> (e,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>)\<^sup>>)\<^sub>u \<sqsubseteq> Q"
      using induct_step by pred_auto
    with PHI
    show "\<Sqinter>st. (p\<^sup>< \<and> e\<^sup>< = \<guillemotleft>st\<guillemotright> \<longrightarrow> q'\<^sup>>)\<^sub>u \<sqsubseteq> Q ;; (p\<^sup>< \<and> (e\<^sup><, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright> \<longrightarrow> q'\<^sup>>)\<^sub>u \<lhd> b \<rhd> II"
      apply pred_auto
      by (smt (z3) hoare_meaning induct_step)+
  qed
  then show ?case by simp
qed
*)

subsection \<open> Frame Rules \<close>

text \<open> Frame rule: If starting $S$ in a state satisfying $p establishes q$ in the final state, then
  we can insert an invariant predicate $r$ when $S$ is framed by $a$, provided that $r$ does not
  refer to variables in the frame, and $q$ does not refer to variables outside the frame. \<close>

(* TODO - Fix all these metis proofs *)

(*
lemma frame_hoare_r:
  assumes "idem_scene a" "a \<sharp> r" "-a \<sharp> q" "\<^bold>{p\<^bold>}P\<^bold>{q\<^bold>}"
  shows "\<^bold>{p \<and> r\<^bold>}a:[P]\<^bold>{q \<and> r\<^bold>}"
  using assms
  apply (pred_auto)
   apply (metis (mono_tags, lifting) Product_Type.Collect_case_prodD frame_def fst_conv hoare_meaning snd_conv)
  by (metis (mono_tags, lifting) Product_Type.Collect_case_prodD frame_def fst_eqD scene_equiv_def scene_override_commute snd_eqD)

lemma frame_strong_hoare_r [hoare_safe]:
  assumes "idem_scene a" "a \<sharp> r" "-a \<sharp> q" "\<^bold>{p \<and> r\<^bold>}S\<^bold>{q\<^bold>}"
  shows "\<^bold>{p \<and> r\<^bold>}a:[S]\<^bold>{q \<and> r\<^bold>}"
  using assms apply (pred_auto)
   apply (metis (mono_tags, lifting) SEXP_def hoare_meaning rel_frame set_pred_def)
  by (metis SEXP_def rel_frame scene_equiv_def scene_override_commute set_pred_def)

lemma frame_hoare_r' [hoare_safe]:
  assumes "idem_scene a" "a \<sharp> r" "-a \<sharp> q" "\<^bold>{r \<and> p\<^bold>}S\<^bold>{q\<^bold>}"
  shows "\<^bold>{r \<and> p\<^bold>}a:[S]\<^bold>{r \<and> q\<^bold>}"
  using assms apply (pred_auto)
   apply (metis SEXP_def rel_frame scene_equiv_def scene_override_commute set_pred_def)
  by (metis (mono_tags, lifting) Product_Type.Collect_case_prodD frame_def fst_conv hoare_meaning snd_conv)

lemma antiframe_hoare_r:
  assumes "idem_scene a" "-a \<sharp> r" "a \<sharp> q" "\<^bold>{p\<^bold>}P\<^bold>{q\<^bold>}"
  shows "\<^bold>{p \<and> r\<^bold>} (-a):[P] \<^bold>{q \<and> r\<^bold>}"
  using assms apply (pred_auto)
   apply (metis (mono_tags, lifting) Product_Type.Collect_case_prodD frame_def fst_conv hoare_meaning snd_conv)
  by (metis (full_types) SEXP_def rel_frame scene_equiv_def scene_override_commute set_pred_def)

lemma antiframe_strong_hoare_r:
  assumes "idem_scene a" "-a \<sharp> r" "a \<sharp> q" "\<^bold>{p \<and> r\<^bold>}P\<^bold>{q\<^bold>}"
  shows "\<^bold>{p \<and> r\<^bold>} (-a):[P] \<^bold>{q \<and> r\<^bold>}"
  using assms  apply (pred_auto)
   apply (metis (mono_tags, lifting) Product_Type.Collect_case_prodD frame_def fst_conv hoare_meaning snd_conv)
  by (metis (full_types) SEXP_def rel_frame scene_equiv_def scene_override_commute set_pred_def)

lemma nmods_invariant:
  assumes "S nmods a" "-a \<sharp> p"
  shows "\<^bold>{p\<^bold>}S\<^bold>{p\<^bold>}"
  using assms apply pred_auto
  by (metis Healthy_def SEXP_def rel_frame scene_equiv_def scene_override_commute set_pred_def)
*)

(*
lemma hoare_r_ghost:
  assumes "vwb_lens x" "x \<sharp> p" "x \<sharp> q" "S nuses x" "\<^bold>{p\<^bold>}x := e;; S\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}S\<^bold>{q\<^bold>}"
proof -
  have "\<^bold>{p\<^bold>}x := e;; rrestr x S\<^bold>{q\<^bold>}"
    by (simp add: Healthy_if assms(4) assms(5))
  with assms(1-3) have "\<^bold>{p\<^bold>}rrestr x S\<^bold>{q\<^bold>}"
    by (rel_simp,metis mwb_lens.put_put vwb_lens_mwb)
  thus ?thesis
    by (simp add: Healthy_if assms(4))
qed *)

end