theory Deleted
  imports HOL.Topological_Spaces
begin

lemma uniformity_multi_trans:
  fixes E :: \<open>('a \<times> 'a::uniform_space) \<Rightarrow> bool\<close>
  assumes \<open>eventually E uniformity\<close>
  obtains D where \<open>eventually (\<lambda>(x,y). D x y) uniformity\<close>
    and \<open>\<And>m. m \<le> n \<Longrightarrow> D ^^ m \<le> (\<lambda>x y. E (x, y))\<close>
proof (atomize_elim, induction n)
  case 0
  show ?case
    by (metis assms bot_nat_0.extremum_unique case_prod_eta refl_ge_eq relpowp.simps(1) uniformity_refl)
next
  define E' where \<open>E' x y = E (x,y)\<close> for x y
  case (Suc n)
  show ?case
  proof (cases \<open>n=0\<close>)
    case True
    then show ?thesis
      using assms apply (auto intro!: exI[of _ \<open>\<lambda>x y. E (x, y)\<close>])
      by (metis (mono_tags, lifting) One_nat_def eq_OO eq_iff le_less_linear less_one relpowp.simps(1) relpowp.simps(2) uniformity_refl)
  next
    case False
    from Suc obtain D where \<open>eventually (case_prod D) uniformity\<close> and D_multitrans: \<open>\<forall>m\<le>n. (D ^^ m) \<le> E'\<close>
      by (auto simp: E'_def le_fun_def)
    obtain D' where D'_uni: \<open>eventually (case_prod D') uniformity\<close> and D'_trans: \<open>D' OO D' \<le> D\<close>
      using uniformity_trans[OF \<open>eventually (case_prod D) uniformity\<close>]
      apply atomize_elim apply (auto simp: le_fun_def OO_def)
      by (metis case_prod_eta)
    have \<open>D' \<le> D\<close>
      using D'_trans D'_uni uniformity_refl by fastforce
    then have pow_mono: \<open>(D' ^^ m) \<le> (D ^^ m)\<close> for m
      apply (induction m) by auto

    have \<open>D' ^^ Suc n = D' OO D' OO (D' ^^ (n-1))\<close>
      by (metis False diff_Suc_1 not0_implies_Suc relpowp.simps(2) relpowp_commute)
    also from D'_trans have \<open>\<dots> \<le> D OO (D' ^^ (n-1))\<close>
      by blast
    also have \<open>\<dots> \<le> D OO (D ^^ (n-1))\<close>
      using pow_mono by blast
    also have \<open>\<dots> = D ^^ n\<close>
      by (metis Suc_pred' neq0_conv relpowp.simps(2) relpowp_commute False)
    also have \<open>\<dots> \<le> E'\<close>
      using D_multitrans by blast
    finally have D'_Sn: \<open>D' ^^ Suc n \<le> E'\<close>
      by -

    from D_multitrans have D'_n: \<open>\<forall>m\<le>n. (D' ^^ m) \<le> E'\<close>
      by (meson order_trans pow_mono)

    from D'_Sn D'_n D'_uni
    show ?thesis
      apply (auto intro!: exI[of _ D'])
      by (metis D'_Sn E'_def le_Suc_eq predicate2D)
  qed
qed

lemma uniformity_eventually_trans[trans]:
  fixes A B C :: \<open>'a \<Rightarrow> 'b :: uniform_space\<close>
  assumes \<open>\<forall>E. eventually E uniformity \<longrightarrow> eventually (\<lambda>x. E (A x, B x)) F\<^sub>1\<close>
  assumes \<open>\<forall>E. eventually E uniformity \<longrightarrow> eventually (\<lambda>x. E (B x, C x)) F\<^sub>2\<close>
  shows \<open>\<forall>E. eventually E uniformity \<longrightarrow> eventually (\<lambda>x. E (A x, C x)) (inf F\<^sub>1 F\<^sub>2)\<close>
proof (intro allI impI)
  fix E :: \<open>('b \<times> 'b) \<Rightarrow> bool\<close>
  assume \<open>eventually E uniformity\<close>
  then obtain D where \<open>eventually D uniformity\<close> and DDE: \<open>D (x, y) \<Longrightarrow> D (y, z) \<Longrightarrow> E (x, z)\<close> for x y z
    apply (rule uniformity_transE) by auto
  with assms have \<open>eventually (\<lambda>x. D (A x, B x)) F\<^sub>1\<close> and \<open>eventually (\<lambda>x. D (B x, C x)) F\<^sub>2\<close>
    by auto
  then show \<open>eventually (\<lambda>x. E (A x, C x)) (inf F\<^sub>1 F\<^sub>2)\<close>
    using DDE eventually_inf by blast
qed

lemma indexed_list_sum:
  assumes \<open>distinct L\<close>
  shows \<open>(\<Sum>i<length L. f (L!i)) = (\<Sum>x\<in>set L. f x)\<close>
  using assms apply (induction L rule:rev_induct)
   apply auto
  by (metis (no_types, lifting) add.commute lessThan_iff nth_append sum.cong)

end


(*  Title:      HOL/ex/SOS_Cert.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Philipp Meyer, TU Muenchen

Examples for Sum_of_Squares: replay of certificates.
*)

theory SOS_Cert
imports "~~/src/HOL/Library/Sum_of_Squares"
begin

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<Longrightarrow> a < 0"
  by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")

lemma "a1 \<ge> 0 \<and> a2 \<ge> 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) \<longrightarrow>
    a1 * a2 - b1 * b2 \<ge> (0::real)"
  by (sos "(((A<0 * R<1) + (([~1/2*a1*b2 + ~1/2*a2*b1] * A=0) + (([~1/2*a1*a2 + 1/2*b1*b2] * A=1) + (((A<0 * R<1) * ((R<1/2 * [b2]^2) + (R<1/2 * [b1]^2))) + ((A<=0 * (A<=1 * R<1)) * ((R<1/2 * [b2]^2) + ((R<1/2 * [b1]^2) + ((R<1/2 * [a2]^2) + (R<1/2 * [a1]^2))))))))))")

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
  by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")

lemma "(0::real) \<le> x \<and> x \<le> 1 \<and> 0 \<le> y \<and> y \<le> 1 \<longrightarrow>
    x\<^sup>2 + y\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + y\<^sup>2 < 1 \<or> x\<^sup>2 + (y - 1)\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + (y - 1)\<^sup>2 < 1"
  by (sos "((R<1 + (((A<=3 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=7 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2)))))))")

lemma "(0::real) \<le> x \<and> 0 \<le> y \<and> 0 \<le> z \<and> x + y + z \<le> 3 \<longrightarrow> x * y + x * z + y * z \<ge> 3 * x * y * z"
  by (sos "(((A<0 * R<1) + (((A<0 * R<1) * (R<1/2 * [1]^2)) + (((A<=2 * R<1) * (R<1/2 * [~1*x + y]^2)) + (((A<=1 * R<1) * (R<1/2 * [~1*x + z]^2)) + (((A<=1 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + (((A<=0 * R<1) * (R<1/2 * [~1*y + z]^2)) + (((A<=0 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + ((A<=0 * (A<=1 * (A<=3 * R<1))) * (R<1/2 * [1]^2))))))))))")

lemma "(x::real)\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (x + y + z)\<^sup>2 \<le> 3"
  by (sos "(((A<0 * R<1) + (([~3] * A=0) + (R<1 * ((R<2 * [~1/2*x + ~1/2*y + z]^2) + (R<3/2 * [~1*x + y]^2))))))")

lemma "w\<^sup>2 + x\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (w + x + y + z)\<^sup>2 \<le> (4::real)"
  by (sos "(((A<0 * R<1) + (([~4] * A=0) + (R<1 * ((R<3 * [~1/3*w + ~1/3*x + ~1/3*y + z]^2) + ((R<8/3 * [~1/2*w + ~1/2*x + y]^2) + (R<2 * [~1*w + x]^2)))))))")

lemma "(x::real) \<ge> 1 \<and> y \<ge> 1 \<longrightarrow> x * y \<ge> x + y - 1"
  by (sos "(((A<0 * R<1) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))")

lemma "(x::real) > 1 \<and> y > 1 \<longrightarrow> x * y > x + y - 1"
  by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * R<1) * (R<1 * [1]^2))))")

lemma "\<bar>x\<bar> \<le> 1 \<longrightarrow> \<bar>64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x\<bar> \<le> (1::real)"
  by (sos "((((A<0 * R<1) + ((A<=1 * R<1) * (R<1 * [~8*x^3 + ~4*x^2 + 4*x + 1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=1 * (A<0 * R<1)) * (R<1 * [8*x^3 + ~4*x^2 + ~4*x + 1]^2)))))")

text \<open>One component of denominator in dodecahedral example.\<close>

lemma "2 \<le> x \<and> x \<le> 125841 / 50000 \<and> 2 \<le> y \<and> y \<le> 125841 / 50000 \<and> 2 \<le> z \<and> z \<le> 125841 / 50000 \<longrightarrow>
    2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) \<ge> (0::real)"
  by (sos "(((A<0 * R<1) + ((R<1 * ((R<5749028157/5000000000 * [~25000/222477*x + ~25000/222477*y + ~25000/222477*z + 1]^2) + ((R<864067/1779816 * [419113/864067*x + 419113/864067*y + z]^2) + ((R<320795/864067 * [419113/1283180*x + y]^2) + (R<1702293/5132720 * [x]^2))))) + (((A<=4 * (A<=5 * R<1)) * (R<3/2 * [1]^2)) + (((A<=3 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<3/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=3 * R<1)) * (R<1/2 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<3/2 * [1]^2)))))))))))))")

text \<open>Over a larger but simpler interval.\<close>

lemma "(2::real) \<le> x \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    0 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by (sos "((R<1 + ((R<1 * ((R<1 * [~1/6*x + ~1/6*y + ~1/6*z + 1]^2) + ((R<1/18 * [~1/2*x + ~1/2*y + z]^2) + (R<1/24 * [~1*x + y]^2)))) + (((A<0 * R<1) * (R<1/12 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1/6 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1/6 * [1]^2)))))))))))")

text \<open>We can do 12. I think 12 is a sharp bound; see PP's certificate.\<close>

lemma "2 \<le> (x::real) \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    12 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by (sos "(((A<0 * R<1) + (((A<=4 * R<1) * (R<2/3 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1 * [1]^2)) + (((A<=3 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * R<1) * (R<2/3 * [1]^2)) + (((A<=2 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * R<1) * (R<2/3 * [1]^2)) + (((A<=0 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=0 * (A<=3 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<8/3 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))))))))))))))))")

text \<open>Inequality from sci.math (see "Leon-Sotelo, por favor").\<close>

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x + y \<le> x\<^sup>2 + y\<^sup>2"
  by (sos "(((A<0 * R<1) + (([1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))")

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x * y * (x + y) \<le> x\<^sup>2 + y\<^sup>2"
  by (sos "(((A<0 * R<1) + (([~1*x + ~1*y + 1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))")

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<longrightarrow> x * y * (x + y)\<^sup>2 \<le> (x\<^sup>2 + y\<^sup>2)\<^sup>2"
  by (sos "(((A<0 * R<1) + (R<1 * ((R<1 * [~1/2*x^2 + y^2 + ~1/2*x*y]^2) + (R<3/4 * [~1*x^2 + x*y]^2)))))")

lemma "(0::real) \<le> a \<and> 0 \<le> b \<and> 0 \<le> c \<and> c * (2 * a + b)^3 / 27 \<le> x \<longrightarrow> c * a\<^sup>2 * b \<le> x"
  by (sos "(((A<0 * R<1) + (((A<=3 * R<1) * (R<1 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/27 * [~1*a + b]^2)) + ((A<=0 * (A<=2 * R<1)) * (R<8/27 * [~1*a + b]^2))))))")

lemma "(0::real) < x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")

lemma "(0::real) \<le> x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")

lemma "(0::real) < 1 + x\<^sup>2"
  by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))")

lemma "(0::real) \<le> 1 + 2 * x + x\<^sup>2"
  by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [x + 1]^2))))")

lemma "(0::real) < 1 + \<bar>x\<bar>"
  by (sos "((R<1 + (((A<=1 * R<1) * (R<1/2 * [1]^2)) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))")

lemma "(0::real) < 1 + (1 + x)\<^sup>2 * \<bar>x\<bar>"
  by (sos "(((R<1 + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [x + 1]^2))))) & ((R<1 + (((A<0 * R<1) * (R<1 * [x + 1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")

lemma "\<bar>(1::real) + x\<^sup>2\<bar> = (1::real) + x\<^sup>2"
  by (sos "(() & (((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<1 * R<1) * (R<1/2 * [1]^2))))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2)))))))")

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
  by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")

lemma "(0::real) < x \<longrightarrow> 1 < y \<longrightarrow> y * x \<le> z \<longrightarrow> x < z"
  by (sos "((((A<0 * A<1) * R<1) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))")

lemma "(1::real) < x \<longrightarrow> x\<^sup>2 < y \<longrightarrow> 1 < y"
  by (sos "((((A<0 * A<1) * R<1) + ((R<1 * ((R<1/10 * [~2*x + y + 1]^2) + (R<1/10 * [~1*x + y]^2))) + (((A<1 * R<1) * (R<1/2 * [1]^2)) + (((A<0 * R<1) * (R<1 * [x]^2)) + (((A<=0 * R<1) * ((R<1/10 * [x + 1]^2) + (R<1/10 * [x]^2))) + (((A<=0 * (A<1 * R<1)) * (R<1/5 * [1]^2)) + ((A<=0 * (A<0 * R<1)) * (R<1/5 * [1]^2)))))))))")

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0"
  by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x^2 + b * x + c \<noteq> 0"
  by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")

lemma "(a::real) * x\<^sup>2 + b * x + c = 0 \<longrightarrow> b\<^sup>2 \<ge> 4 * a * c"
  by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")

lemma "(0::real) \<le> b \<and> 0 \<le> c \<and> 0 \<le> x \<and> 0 \<le> y \<and> x\<^sup>2 = c \<and> y\<^sup>2 = a\<^sup>2 * c + b \<longrightarrow> a * c \<le> y * x"
  by (sos "(((A<0 * (A<0 * R<1)) + (((A<=2 * (A<=3 * (A<0 * R<1))) * (R<2 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2)))))")

lemma "\<bar>x - z\<bar> \<le> e \<and> \<bar>y - z\<bar> \<le> e \<and> 0 \<le> u \<and> 0 \<le> v \<and> u + v = 1 \<longrightarrow> \<bar>(u * x + v * y) - z\<bar> \<le> (e::real)"
  by (sos "((((A<0 * R<1) + (((A<=3 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2))))) & ((((A<0 * A<1) * R<1) + (((A<=3 * (A<=5 * (A<0 * R<1))) * (R<1 * [1]^2)) + ((A<=1 * (A<=4 * (A<0 * R<1))) * (R<1 * [1]^2))))))")

lemma "(x::real) - y - 2 * x^4 = 0 \<and> 0 \<le> x \<and> x \<le> 2 \<and> 0 \<le> y \<and> y \<le> 3 \<longrightarrow> y\<^sup>2 - 7 * y - 12 * x + 17 \<ge> 0"
  oops (*Too hard?*)

lemma "(0::real) \<le> x \<longrightarrow> (1 + x + x\<^sup>2) / (1 + x\<^sup>2) \<le> 1 + x"
  by (sos "(((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2))))))")

lemma "(0::real) \<le> x \<longrightarrow> 1 - x \<le> 1 / (1 + x + x\<^sup>2)"
  by (sos "(((R<1 + (([~4/3] * A=0) + ((R<1 * ((R<1/3 * [3/2*x + 1]^2) + (R<7/12 * [x]^2))) + ((A<=0 * R<1) * (R<1/3 * [1]^2)))))) & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))))")

lemma "(x::real) \<le> 1 / 2 \<longrightarrow> - x - 2 * x\<^sup>2 \<le> - x / (1 - x)"
  by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2))))")

lemma "4 * r\<^sup>2 = p\<^sup>2 - 4 * q \<and> r \<ge> (0::real) \<and> x\<^sup>2 + p * x + q = 0 \<longrightarrow> 2 * (x::real) = - p + 2 * r \<or> 2 * x = - p - 2 * r"
  by (sos "((((((A<0 * A<1) * R<1) + ([~4] * A=0))) & ((((A<0 * A<1) * R<1) + ([4] * A=0)))) & (((((A<0 * A<1) * R<1) + ([4] * A=0))) & ((((A<0 * A<1) * R<1) + ([~4] * A=0)))))")

end


(* Author: Alexander Maletzky *)

section \<open>Preliminaries\<close>

theory Dube_Prelims
  imports Groebner_Bases.General
begin

subsection \<open>Sets\<close>

lemma card_geq_ex_subset:
  assumes "card A \<ge> n"
  obtains B where "card B = n" and "B \<subseteq> A"
  using assms
proof (induct n arbitrary: thesis)
  case base: 0
  show ?case
  proof (rule base(1))
    show "card {} = 0" by simp
  next
    show "{} \<subseteq> A" ..
  qed
next
  case ind: (Suc n)
  from ind(3) have "n < card A" by simp
  obtain B where card: "card B = n" and "B \<subseteq> A"
  proof (rule ind(1))
    from \<open>n < card A\<close> show "n \<le> card A" by simp
  qed
  from \<open>n < card A\<close> have "card A \<noteq> 0" by simp
  with card.infinite[of A] have "finite A" by blast
  let ?C = "A - B"
  have "?C \<noteq> {}"
  proof
    assume "A - B = {}"
    hence "A \<subseteq> B" by simp
    from this \<open>B \<subseteq> A\<close> have "A = B" ..
    from \<open>n < card A\<close> show False unfolding \<open>A = B\<close> card by simp
  qed
  then obtain c where "c \<in> ?C" by auto
  hence "c \<notin> B" by simp
  hence "B - {c} = B" by simp
  show ?case
  proof (rule ind(2))
    thm card.insert_remove
    have "card (B \<union> {c}) = card (insert c B)" by simp
    also have "... = Suc (card (B - {c}))"
      by (rule card.insert_remove, rule finite_subset, fact \<open>B \<subseteq> A\<close>, fact)
    finally show "card (B \<union> {c}) = Suc n" unfolding \<open>B - {c} = B\<close> card .
  next
    show "B \<union> {c} \<subseteq> A" unfolding Un_subset_iff
    proof (intro conjI, fact)
      from \<open>c \<in> ?C\<close> show "{c} \<subseteq> A" by auto
    qed
  qed
qed

lemma card_2_E_1:
  assumes "card A = 2" and "x \<in> A"
  obtains y where "x \<noteq> y" and "A = {x, y}"
proof -
  have "A - {x} \<noteq> {}"
  proof
    assume "A - {x} = {}"
    with assms(2) have "A = {x}" by auto
    hence "card A = 1" by simp
    with assms show False by simp
  qed
  then obtain y where "y \<in> A - {x}" by auto
  hence "y \<in> A" and "x \<noteq> y" by auto
  show ?thesis
  proof
    show "A = {x, y}"
    proof (rule sym, rule card_seteq)
      from assms(1) show "finite A" using card.infinite by fastforce
    next
      from \<open>x \<in> A\<close> \<open>y \<in> A\<close> show "{x, y} \<subseteq> A" by simp
    next
      from \<open>x \<noteq> y\<close> show "card A \<le> card {x, y}" by (simp add: assms(1))
    qed
  qed fact
qed

lemma card_2_E:
  assumes "card A = 2"
  obtains x y where "x \<noteq> y" and "A = {x, y}"
proof -
  from assms have "A \<noteq> {}" by auto
  then obtain x where "x \<in> A" by blast
  with assms obtain y where "x \<noteq> y" and "A = {x, y}" by (rule card_2_E_1)
  thus ?thesis ..
qed

subsection \<open>Sums\<close>

lemma sum_tail_nat: "0 < b \<Longrightarrow> a \<le> (b::nat) \<Longrightarrow> sum f {a..b} = f b + sum f {a..b - 1}"
  by (metis One_nat_def Suc_pred add.commute not_le sum.cl_ivl_Suc)

lemma sum_atLeast_Suc_shift: "0 < b \<Longrightarrow> a \<le> b \<Longrightarrow> sum f {Suc a..b} = (\<Sum>i=a..b - 1. f (Suc i))"
  by (metis Suc_pred' sum.shift_bounds_cl_Suc_ivl)

lemma sum_split_nat_ivl:
  "a \<le> Suc j \<Longrightarrow> j \<le> b \<Longrightarrow> sum f {a..j} + sum f {Suc j..b} = sum f {a..b}"
  by (metis Suc_eq_plus1 le_Suc_ex sum.ub_add_nat)

subsection \<open>@{const count_list}\<close>

lemma count_list_gr_1_E:
  assumes "1 < count_list xs x"
  obtains i j where "i < j" and "j < length xs" and "xs ! i = x" and "xs ! j = x"
proof -
  from assms have "count_list xs x \<noteq> 0" by simp
  hence "x \<in> set xs" by (simp only: count_list_0_iff not_not)
  then obtain ys zs where xs: "xs = ys @ x # zs" and "x \<notin> set ys" by (meson split_list_first)
  hence "count_list xs x = Suc (count_list zs x)" by (simp)
  with assms have "count_list zs x \<noteq> 0" by simp
  hence "x \<in> set zs" by (simp only: count_list_0_iff not_not)
  then obtain j where "j < length zs" and "x = zs ! j" by (metis in_set_conv_nth)
  show ?thesis
  proof
    show "length ys < length ys + Suc j" by simp
  next
    from \<open>j < length zs\<close> show "length ys + Suc j < length xs" by (simp add: xs)
  next
    show "xs ! length ys = x" by (simp add: xs)
  next
    show "xs ! (length ys + Suc j) = x"
      by (simp only: xs \<open>x = zs ! j\<close> nth_append_length_plus nth_Cons_Suc)
  qed
qed

subsection \<open>@{const listset}\<close>

lemma listset_Cons: "listset (x # xs) = (\<Union>y\<in>x. (#) y ` listset xs)"
  by (auto simp: set_Cons_def)

lemma listset_ConsI: "y \<in> x \<Longrightarrow> ys' \<in> listset xs \<Longrightarrow> ys = y # ys' \<Longrightarrow> ys \<in> listset (x # xs)"
  by (simp add: set_Cons_def)

lemma listset_ConsE:
  assumes "ys \<in> listset (x# xs)"
  obtains y ys' where "y \<in> x" and "ys' \<in> listset xs" and "ys = y # ys'"
  using assms by (auto simp: set_Cons_def)

lemma listsetI:
  "length ys = length xs \<Longrightarrow> (\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i) \<Longrightarrow> ys \<in> listset xs"
  by (induct ys xs rule: list_induct2)
     (simp_all, smt Suc_mono list.sel(3) mem_Collect_eq nth_Cons_0 nth_tl set_Cons_def zero_less_Suc)

lemma listsetD:
  assumes "ys \<in> listset xs"
  shows "length ys = length xs" and "\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i"
proof -
  from assms have "length ys = length xs \<and> (\<forall>i<length xs. ys ! i \<in> xs ! i)"
  proof (induct xs arbitrary: ys)
    case Nil
    thus ?case by simp
  next
    case (Cons x xs)
    from Cons.prems obtain y ys' where "y \<in> x" and "ys' \<in> listset xs" and ys: "ys = y # ys'"
      by (rule listset_ConsE)
    from this(2) have "length ys' = length xs \<and> (\<forall>i<length xs. ys' ! i \<in> xs ! i)" by (rule Cons.hyps)
    hence 1: "length ys' = length xs" and 2: "\<And>i. i < length xs \<Longrightarrow> ys' ! i \<in> xs ! i" by simp_all
    show ?case
    proof (intro conjI allI impI)
      fix i
      assume "i < length (x # xs)"
      show "ys ! i \<in> (x # xs) ! i"
      proof (cases i)
        case 0
        with \<open>y \<in> x\<close> show ?thesis by (simp add: ys)
      next
        case (Suc j)
        with \<open>i < length (x # xs)\<close> have "j < length xs" by simp
        hence "ys' ! j \<in> xs ! j" by (rule 2)
        thus ?thesis by (simp add: ys \<open>i = Suc j\<close>)
      qed
    qed (simp add: ys 1)
  qed
  thus "length ys = length xs" and "\<And>i. i < length xs \<Longrightarrow> ys ! i \<in> xs ! i" by simp_all
qed

lemma listset_singletonI: "a \<in> A \<Longrightarrow> ys = [a] \<Longrightarrow> ys \<in> listset [A]"
  by simp

lemma listset_singletonE:
  assumes "ys \<in> listset [A]"
  obtains a where "a \<in> A" and "ys = [a]"
  using assms by auto

lemma listset_doubletonI: "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> ys = [a, b] \<Longrightarrow> ys \<in> listset [A, B]"
  by (simp add: set_Cons_def)

lemma listset_doubletonE:
  assumes "ys \<in> listset [A, B]"
  obtains a b where "a \<in> A" and "b \<in> B" and "ys = [a, b]"
  using assms by (auto simp: set_Cons_def)

lemma listset_appendI:
  "ys1 \<in> listset xs1 \<Longrightarrow> ys2 \<in> listset xs2 \<Longrightarrow> ys = ys1 @ ys2 \<Longrightarrow> ys \<in> listset (xs1 @ xs2)"
  by (induct xs1 arbitrary: ys ys1 ys2)
      (simp, auto simp del: listset.simps elim!: listset_ConsE intro!: listset_ConsI)

lemma listset_appendE:
  assumes "ys \<in> listset (xs1 @ xs2)"
  obtains ys1 ys2 where "ys1 \<in> listset xs1" and "ys2 \<in> listset xs2" and "ys = ys1 @ ys2"
  using assms
proof (induct xs1 arbitrary: thesis ys)
  case Nil
  have "[] \<in> listset []" by simp
  moreover from Nil(2) have "ys \<in> listset xs2" by simp
  ultimately show ?case by (rule Nil) simp
next
  case (Cons x xs1)
  from Cons.prems(2) have "ys \<in> listset (x # (xs1 @ xs2))" by simp
  then obtain y ys' where "y \<in> x" and "ys' \<in> listset (xs1 @ xs2)" and ys: "ys = y # ys'"
    by (rule listset_ConsE)
  from _ this(2) obtain ys1 ys2 where ys1: "ys1 \<in> listset xs1" and "ys2 \<in> listset xs2"
    and ys': "ys' = ys1 @ ys2" by (rule Cons.hyps)
  show ?case
  proof (rule Cons.prems)
    from \<open>y \<in> x\<close> ys1 refl show "y # ys1 \<in> listset (x # xs1)" by (rule listset_ConsI)
  next
    show "ys = (y # ys1) @ ys2" by (simp add: ys ys')
  qed fact
qed

lemma listset_map_imageI: "ys' \<in> listset xs \<Longrightarrow> ys = map f ys' \<Longrightarrow> ys \<in> listset (map ((`) f) xs)"
  by (induct xs arbitrary: ys ys')
    (simp, auto simp del: listset.simps elim!: listset_ConsE intro!: listset_ConsI)

lemma listset_map_imageE:
  assumes "ys \<in> listset (map ((`) f) xs)"
  obtains ys' where "ys' \<in> listset xs" and "ys = map f ys'"
  using assms
proof (induct xs arbitrary: thesis ys)
  case Nil
  from Nil(2) have "ys = map f []" by simp
  with _ show ?case by (rule Nil) simp
next
  case (Cons x xs)
  from Cons.prems(2) have "ys \<in> listset (f ` x # map ((`) f) xs)" by simp
  then obtain y ys' where "y \<in> f ` x" and "ys' \<in> listset (map ((`) f) xs)" and ys: "ys = y # ys'"
    by (rule listset_ConsE)
  from _ this(2) obtain ys1 where ys1: "ys1 \<in> listset xs" and ys': "ys' = map f ys1" by (rule Cons.hyps)
  from \<open>y \<in> f ` x\<close> obtain y1 where "y1 \<in> x" and y: "y = f y1" ..
  show ?case
  proof (rule Cons.prems)
    from \<open>y1 \<in> x\<close> ys1 refl show "y1 # ys1 \<in> listset (x # xs)" by (rule listset_ConsI)
  qed (simp add: ys ys' y)
qed

lemma listset_permE:
  assumes "ys \<in> listset xs" and "bij_betw f {..<length xs} {..<length xs'}"
    and "\<And>i. i < length xs \<Longrightarrow> xs' ! i = xs ! f i"
  obtains ys' where "ys' \<in> listset xs'" and "length ys' = length ys"
    and "\<And>i. i < length ys \<Longrightarrow> ys' ! i = ys ! f i"
proof -
  from assms(1) have len_ys: "length ys = length xs" by (rule listsetD)
  from assms(2) have "card {..<length xs} = card {..<length xs'}" by (rule bij_betw_same_card)
  hence len_xs: "length xs = length xs'" by simp
  define ys' where "ys' = map (\<lambda>i. ys ! (f i)) [0..<length ys]"
  have 1: "ys' ! i = ys ! f i" if "i < length ys" for i using that by (simp add: ys'_def)
  show ?thesis
  proof
    show "ys' \<in> listset xs'"
    proof (rule listsetI)
      show "length ys' = length xs'" by (simp add: ys'_def len_ys len_xs)

      fix i
      assume "i < length xs'"
      hence "i < length xs" by (simp only: len_xs)
      hence "i < length ys" by (simp only: len_ys)
      hence "ys' ! i = ys ! (f i)" by (rule 1)
      also from assms(1) have "\<dots> \<in> xs ! (f i)"
      proof (rule listsetD)
        from \<open>i < length xs\<close> have "i \<in> {..<length xs}" by simp
        hence "f i \<in> f ` {..<length xs}" by (rule imageI)
        also from assms(2) have "\<dots> = {..<length xs'}" by (simp add: bij_betw_def)
        finally show "f i < length xs" by (simp add: len_xs)
      qed
      also have "\<dots> = xs' ! i" by (rule sym) (rule assms(3), fact)
      finally show "ys' ! i \<in> xs' ! i" .
    qed
  next
    show "length ys' = length ys" by (simp add: ys'_def)
  qed (rule 1)
qed

lemma listset_closed_map:
  assumes "ys \<in> listset xs" and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> x \<Longrightarrow> f y \<in> x"
  shows "map f ys \<in> listset xs"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  from Nil(1) show ?case by simp
next
  case (Cons x xs)
  from Cons.prems(1) obtain y ys' where "y \<in> x" and "ys' \<in> listset xs" and ys: "ys = y # ys'"
    by (rule listset_ConsE)
  show ?case
  proof (rule listset_ConsI)
    from _ \<open>y \<in> x\<close> show "f y \<in> x" by (rule Cons.prems) simp
  next
    show "map f ys' \<in> listset xs"
    proof (rule Cons.hyps)
      fix x0 y0
      assume "x0 \<in> set xs"
      hence "x0 \<in> set (x # xs)" by simp
      moreover assume "y0 \<in> x0"
      ultimately show "f y0 \<in> x0" by (rule Cons.prems)
    qed fact
  qed (simp add: ys)
qed

lemma listset_closed_map2:
  assumes "ys1 \<in> listset xs" and "ys2 \<in> listset xs"
    and "\<And>x y1 y2. x \<in> set xs \<Longrightarrow> y1 \<in> x \<Longrightarrow> y2 \<in> x \<Longrightarrow> f y1 y2 \<in> x"
  shows "map2 f ys1 ys2 \<in> listset xs"
  using assms
proof (induct xs arbitrary: ys1 ys2)
  case Nil
  from Nil(1) show ?case by simp
next
  case (Cons x xs)
  from Cons.prems(1) obtain y1 ys1' where "y1 \<in> x" and "ys1' \<in> listset xs" and ys1: "ys1 = y1 # ys1'"
    by (rule listset_ConsE)
  from Cons.prems(2) obtain y2 ys2' where "y2 \<in> x" and "ys2' \<in> listset xs" and ys2: "ys2 = y2 # ys2'"
    by (rule listset_ConsE)
  show ?case
  proof (rule listset_ConsI)
    from _ \<open>y1 \<in> x\<close> \<open>y2 \<in> x\<close> show "f y1 y2 \<in> x" by (rule Cons.prems) simp
  next
    show "map2 f ys1' ys2' \<in> listset xs"
    proof (rule Cons.hyps)
      fix x' y1' y2'
      assume "x' \<in> set xs"
      hence "x' \<in> set (x # xs)" by simp
      moreover assume "y1' \<in> x'" and "y2' \<in> x'"
      ultimately show "f y1' y2' \<in> x'" by (rule Cons.prems)
    qed fact+
  qed (simp add: ys1 ys2)
qed

lemma listset_empty_iff: "listset xs = {} \<longleftrightarrow> {} \<in> set xs"
  by (induct xs) (auto simp: listset_Cons simp del: listset.simps(2))

lemma listset_mono:
  assumes "length xs = length ys" and "\<And>i. i < length ys \<Longrightarrow> xs ! i \<subseteq> ys ! i"
  shows "listset xs \<subseteq> listset ys"
  using assms
proof (induct xs ys rule: list_induct2)
  case Nil
  show ?case by simp
next
  case (Cons x xs y ys)
  show ?case
  proof
    fix zs'
    assume "zs' \<in> listset (x # xs)"
    then obtain z zs where "z \<in> x" and zs: "zs \<in> listset xs" and zs': "zs' = z # zs"
      by (rule listset_ConsE)
    have "0 < length (y # ys)" by simp
    hence "(x # xs) ! 0 \<subseteq> (y # ys) ! 0" by (rule Cons.prems)
    hence "x \<subseteq> y" by simp
    with \<open>z \<in> x\<close> have "z \<in> y" ..
    moreover from zs have "zs \<in> listset ys"
    proof
      show "listset xs \<subseteq> listset ys"
      proof (rule Cons.hyps)
        fix i
        assume "i < length ys"
        hence "Suc i < length (y # ys)" by simp
        hence "(x # xs) ! Suc i \<subseteq> (y # ys) ! Suc i" by (rule Cons.prems)
        thus "xs ! i \<subseteq> ys ! i" by simp
      qed
    qed
    ultimately show "zs' \<in> listset (y # ys)" using zs' by (rule listset_ConsI)
  qed
qed

end (* theory *)


theory Confluent_Quotient imports
  Confluence
begin

text \<open>Functors with finite setters preserve wide intersection for any equivalence relation that respects the mapper.\<close>

lemma Inter_finite_subset:
  assumes "\<forall>A \<in> \<A>. finite A"
  shows "\<exists>\<B>\<subseteq>\<A>. finite \<B> \<and> (\<Inter>\<B>) = (\<Inter>\<A>)"
proof(cases "\<A> = {}")
  case False
  then obtain A where A: "A \<in> \<A>" by auto
  then have finA: "finite A" using assms by auto
  hence fin: "finite (A - \<Inter>\<A>)" by(rule finite_subset[rotated]) auto
  let ?P = "\<lambda>x A. A \<in> \<A> \<and> x \<notin> A"
  define f where "f x = Eps (?P x)" for x
  let ?\<B> = "insert A (f ` (A - \<Inter>\<A>))"
  have "?P x (f x)" if "x \<in> A - \<Inter>\<A>" for x unfolding f_def by(rule someI_ex)(use that A in auto)
  hence "(\<Inter>?\<B>) = (\<Inter>\<A>)" "?\<B> \<subseteq> \<A>" using A by auto
  moreover have "finite ?\<B>" using fin by simp
  ultimately show ?thesis by blast
qed simp

locale wide_intersection_finite =
  fixes E :: "'Fa \<Rightarrow> 'Fa \<Rightarrow> bool"
    and mapFa :: "('a \<Rightarrow> 'a) \<Rightarrow> 'Fa \<Rightarrow> 'Fa"
    and setFa :: "'Fa \<Rightarrow> 'a set"
  assumes equiv: "equivp E"
    and map_E: "E x y \<Longrightarrow> E (mapFa f x) (mapFa f y)"
    and map_id: "mapFa id x = x"
    and map_cong: "\<forall>a\<in>setFa x. f a = g a \<Longrightarrow> mapFa f x = mapFa g x"
    and set_map: "setFa (mapFa f x) = f ` setFa x"
    and finite: "finite (setFa x)"
begin

lemma binary_intersection:
  assumes "E y z" and y: "setFa y \<subseteq> Y" and z: "setFa z \<subseteq> Z" and a: "a \<in> Y" "a \<in> Z"
  shows "\<exists>x. E x y \<and> setFa x \<subseteq> Y \<and> setFa x \<subseteq> Z"
proof -
  let ?f = "\<lambda>b. if b \<in> Z then b else a"
  let ?u = "mapFa ?f y"
  from \<open>E y z\<close> have "E ?u (mapFa ?f z)" by(rule map_E)
  also have "mapFa ?f z = mapFa id z" by(rule map_cong)(use z in auto)
  also have "\<dots> = z" by(rule map_id)
  finally have "E ?u y" using \<open>E y z\<close> equivp_symp[OF equiv] equivp_transp[OF equiv] by blast
  moreover have "setFa ?u \<subseteq> Y" using a y by(subst set_map) auto
  moreover have "setFa ?u \<subseteq> Z" using a by(subst set_map) auto
  ultimately show ?thesis by blast
qed

lemma finite_intersection:
  assumes E: "\<forall>y\<in>A. E y z"
    and fin: "finite A"
    and sub: "\<forall>y\<in>A. setFa y \<subseteq> Y y \<and> a \<in> Y y"
  shows "\<exists>x. E x z \<and> (\<forall>y\<in>A. setFa x \<subseteq> Y y)"
  using fin E sub
proof(induction)
  case empty
  then show ?case using equivp_reflp[OF equiv, of z] by(auto)
next
  case (insert y A)
  then obtain x where x: "E x z" "\<forall>y\<in>A. setFa x \<subseteq> Y y \<and> a \<in> Y y" by auto
  hence set_x: "setFa x \<subseteq> (\<Inter>y\<in>A. Y y)" "a \<in> (\<Inter>y\<in>A. Y y)" by auto
  from insert.prems have "E y z" and set_y: "setFa y \<subseteq> Y y" "a \<in> Y y" by auto
  from \<open>E y z\<close> \<open>E x z\<close> have "E x y" using equivp_symp[OF equiv] equivp_transp[OF equiv] by blast
  from binary_intersection[OF this set_x(1) set_y(1) set_x(2) set_y(2)]
  obtain x' where "E x' x" "setFa x' \<subseteq> \<Inter> (Y ` A)" "setFa x' \<subseteq> Y y" by blast
  then show ?case using \<open>E x z\<close> equivp_transp[OF equiv] by blast
qed

lemma wide_intersection:
  assumes inter_nonempty: "\<Inter> Ss \<noteq> {}"
  shows "(\<Inter>As \<in> Ss. {(x, x'). E x x'} `` {x. setFa x \<subseteq> As}) \<subseteq> {(x, x'). E x x'} `` {x. setFa x \<subseteq> \<Inter> Ss}" (is "?lhs \<subseteq> ?rhs")
proof
  fix x
  assume lhs: "x \<in> ?lhs"
  from inter_nonempty obtain a where a: "\<forall>As \<in> Ss. a \<in> As" by auto
  from lhs obtain y where y: "\<And>As. As \<in> Ss \<Longrightarrow> E (y As) x \<and> setFa (y As) \<subseteq> As"
    by atomize_elim(rule choice, auto)
  define Ts where "Ts = (\<lambda>As. insert a (setFa (y As))) ` Ss"
  have Ts_subset: "(\<Inter>Ts) \<subseteq> (\<Inter>Ss)" using a unfolding Ts_def by(auto dest: y)
  have Ts_finite: "\<forall>Bs \<in> Ts. finite Bs" unfolding Ts_def by(auto dest: y intro: finite)
  from Inter_finite_subset[OF this] obtain Us
    where Us: "Us \<subseteq> Ts" and finite_Us: "finite Us" and Int_Us: "(\<Inter>Us) \<subseteq> (\<Inter>Ts)" by force
  let ?P = "\<lambda>U As. As \<in> Ss \<and> U = insert a (setFa (y As))"
  define Y where "Y U = Eps (?P U)" for U
  have Y: "?P U (Y U)" if "U \<in> Us" for U unfolding Y_def
    by(rule someI_ex)(use that Us in \<open>auto simp add: Ts_def\<close>)
  let ?f = "\<lambda>U. y (Y U)"
  have *: "\<forall>z\<in>(?f ` Us). E z x" by(auto dest!: Y y)
  have **: "\<forall>z\<in>(?f ` Us). setFa z \<subseteq> insert a (setFa z) \<and> a \<in> insert a (setFa z)" by auto
  from finite_intersection[OF * _ **] finite_Us obtain u
    where u: "E u x" and set_u: "\<forall>z\<in>(?f ` Us). setFa u \<subseteq> insert a (setFa z)" by auto
  from set_u have "setFa u \<subseteq> (\<Inter> Us)" by(auto dest: Y)
  with Int_Us Ts_subset have "setFa u \<subseteq> (\<Inter> Ss)" by auto
  with u show "x \<in> ?rhs" by auto
qed

end

text \<open>Subdistributivity for quotients via confluence\<close>

lemma rtranclp_transp_reflp: "R\<^sup>*\<^sup>* = R" if "transp R" "reflp R"
  apply(rule ext iffI)+
  subgoal premises prems for x y using prems by(induction)(use that in \<open>auto intro: reflpD transpD\<close>)
  subgoal by(rule r_into_rtranclp)
  done

lemma rtranclp_equivp: "R\<^sup>*\<^sup>* = R" if "equivp R"
  using that by(simp add: rtranclp_transp_reflp equivp_reflp_symp_transp)

locale confluent_quotient =
  fixes Rb :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
    and Ea :: "'Fa \<Rightarrow> 'Fa \<Rightarrow> bool"
    and Eb :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
    and Ec :: "'Fc \<Rightarrow> 'Fc \<Rightarrow> bool"
    and Eab :: "'Fab \<Rightarrow> 'Fab \<Rightarrow> bool"
    and Ebc :: "'Fbc \<Rightarrow> 'Fbc \<Rightarrow> bool"
    and \<pi>_Faba :: "'Fab \<Rightarrow> 'Fa"
    and \<pi>_Fabb :: "'Fab \<Rightarrow> 'Fb"
    and \<pi>_Fbcb :: "'Fbc \<Rightarrow> 'Fb"
    and \<pi>_Fbcc :: "'Fbc \<Rightarrow> 'Fc"
    and rel_Fab :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fb \<Rightarrow> bool"
    and rel_Fbc :: "('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fb \<Rightarrow> 'Fc \<Rightarrow> bool"
    and rel_Fac :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fc \<Rightarrow> bool"
    and set_Fab :: "'Fab \<Rightarrow> ('a \<times> 'b) set"
    and set_Fbc :: "'Fbc \<Rightarrow> ('b \<times> 'c) set"
  assumes confluent: "confluentp Rb"
    and retract1_ab: "\<And>x y. Rb (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z \<and> set_Fab z \<subseteq> set_Fab x"
    and retract1_bc: "\<And>x y. Rb (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z \<and> set_Fbc z \<subseteq> set_Fbc x"
    and generated_b: "Eb \<le> equivclp Rb"
    and transp_a: "transp Ea"
    and transp_c: "transp Ec"
    and equivp_ab: "equivp Eab"
    and equivp_bc: "equivp Ebc"
    and in_rel_Fab: "\<And>A x y. rel_Fab A x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fab x \<subseteq> {(x, y). A x y}} \<and> \<pi>_Faba z = x \<and> \<pi>_Fabb z = y)"
    and in_rel_Fbc: "\<And>B x y. rel_Fbc B x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fbc x \<subseteq> {(x, y). B x y}} \<and> \<pi>_Fbcb z = x \<and> \<pi>_Fbcc z = y)"
    and rel_compp: "\<And>A B. rel_Fac (A OO B) = rel_Fab A OO rel_Fbc B"
    and \<pi>_Faba_respect: "rel_fun Eab Ea \<pi>_Faba \<pi>_Faba"
    and \<pi>_Fbcc_respect: "rel_fun Ebc Ec \<pi>_Fbcc \<pi>_Fbcc"
begin

lemma retract_ab: "Rb\<^sup>*\<^sup>* (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z \<and> set_Fab z \<subseteq> set_Fab x"
  by(induction rule: rtranclp_induct)(blast dest: retract1_ab intro: equivp_transp[OF equivp_ab] equivp_reflp[OF equivp_ab])+

lemma retract_bc: "Rb\<^sup>*\<^sup>* (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z \<and> set_Fbc z \<subseteq> set_Fbc x"
  by(induction rule: rtranclp_induct)(blast dest: retract1_bc intro: equivp_transp[OF equivp_bc] equivp_reflp[OF equivp_bc])+

lemma subdistributivity: "rel_Fab A OO Eb OO rel_Fbc B \<le> Ea OO rel_Fac (A OO B) OO Ec"
proof(rule predicate2I; elim relcomppE)
  fix x y y' z
  assume "rel_Fab A x y" and "Eb y y'" and "rel_Fbc B y' z"
  then obtain xy y'z
    where xy: "set_Fab xy \<subseteq> {(a, b). A a b}" "x = \<pi>_Faba xy" "y = \<pi>_Fabb xy"
      and y'z: "set_Fbc y'z \<subseteq> {(a, b). B a b}" "y' = \<pi>_Fbcb y'z" "z = \<pi>_Fbcc y'z"
    by(auto simp add: in_rel_Fab in_rel_Fbc)
  from \<open>Eb y y'\<close> have "equivclp Rb y y'" using generated_b by blast
  then obtain u where u: "Rb\<^sup>*\<^sup>* y u" "Rb\<^sup>*\<^sup>* y' u"
    unfolding semiconfluentp_equivclp[OF confluent[THEN confluentp_imp_semiconfluentp]]
    by(auto simp add: rtranclp_conversep)
  with xy y'z obtain xy' y'z'
    where retract1: "Eab xy xy'" "\<pi>_Fabb xy' = u" "set_Fab xy' \<subseteq> set_Fab xy"
      and retract2: "Ebc y'z y'z'" "\<pi>_Fbcb y'z' = u" "set_Fbc y'z' \<subseteq> set_Fbc y'z"
    by(auto dest!: retract_ab retract_bc)
  from retract1(1) xy have "Ea x (\<pi>_Faba xy')" by(auto dest: \<pi>_Faba_respect[THEN rel_funD])
  moreover have "rel_Fab A (\<pi>_Faba xy') u" using xy retract1 by(auto simp add: in_rel_Fab)
  moreover have "rel_Fbc B u (\<pi>_Fbcc y'z')" using y'z retract2 by(auto simp add: in_rel_Fbc)
  moreover have "Ec (\<pi>_Fbcc y'z') z" using retract2 y'z equivp_symp[OF equivp_bc]
    by(auto intro: \<pi>_Fbcc_respect[THEN rel_funD])
  ultimately show "(Ea OO rel_Fac (A OO B) OO Ec) x z" unfolding rel_compp by blast
qed

end

end


theory HSem
  imports "HeapToEnv" "DistinctVars-Nominal" "HOLCF-Fix-Join-Nominal" "FMap-Utils"
begin

subsubsection {* A locale for heap semantics, abstract in the expression semantics *}

text {*
The following theory about the semantics of a heap is abstract in the type and
semantics of expressions. Also, care is taken that lemmas required to prove
continuity of the heap semantics are provideded before requiring full
continuity of the expression semantics, to allow for a mutually recursive
proof.
*}

locale has_ESem =
  fixes ESem :: "'exp::pt \<Rightarrow> 'var::{cont_pt,at_base} f\<rightharpoonup> 'value \<Rightarrow> 'value::{pure_cpo,Nonempty_Meet_cpo,pcpo}"
begin

text {*
This definition captures the notion of compatible heaps and environments, i.e.\ those heaps where,
in the course of calculating the semantics, all joins exist.
*}

abbreviation HSem_cond' :: "('var \<times> 'exp) list \<Rightarrow> 'var f\<rightharpoonup> 'value \<Rightarrow> bool"
  where "HSem_cond' h \<rho> \<equiv>
      fix_join_cond (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
                        (\<lambda> \<rho>' . heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"

text {*
The following definition is in fact just
\[
@{text "\<lbrace>h\<rbrace>\<rho> = \<rho>'. \<rho> \<squnion> heapToEnv h (\<lbrakk>-\<rbrakk>\<^bsub>\<rho>'\<^esub>)"}
\]
with addiditional book-keeping for domain of the map and the condition that all joins exist.
*}

definition HSem :: "('var \<times> 'exp) list \<Rightarrow> 'var f\<rightharpoonup> 'value \<Rightarrow> 'var f\<rightharpoonup> 'value"
  where
  "HSem h \<rho> =
    (if HSem_cond' h \<rho>
    then fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>' . heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))
      (\<lambda> \<rho>'. \<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
    else (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"

text {*
Given the predcondition hold, we can unfold the definition directly.
*}

lemma HSem_def': "HSem_cond' \<Gamma> \<rho> \<Longrightarrow>
  HSem \<Gamma> \<rho> = fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>) (\<lambda>\<rho>'. heapToEnv \<Gamma> (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>))
           (\<lambda>\<rho>'. \<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub> \<squnion> heapToEnv \<Gamma> (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)
 "
  unfolding  HSem_def
  by (subst if_P, auto)

subsubsection {* Continutiy of the heap semantics *}

lemma HSem_monofun'':
  assumes cont: "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  assumes cond1: "HSem_cond' h \<rho>"
  assumes cond2: "HSem_cond' h \<rho>'"
  assumes "\<rho> \<sqsubseteq> \<rho>'"
  shows "HSem h \<rho> \<sqsubseteq> HSem h \<rho>'"
    unfolding HSem_def
    unfolding if_P[OF cond1] if_P[OF cond2]
    apply (rule fix_on_mono2[OF fix_on_cond_fjc[OF cond1] fix_on_cond_fjc[OF cond2]])
    apply (simp add: bottom_of_fjc to_bot_fmap_def fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`])
    apply (erule (1) join_mono[OF rho_F_compat_fjc[OF cond1] rho_F_compat_fjc[OF cond2]])
    apply (subst fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`], rule monofunE[OF fmap_expand_monofun assms(4)])
    apply (subst fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`], rule monofunE[OF fmap_expand_monofun])
    apply (erule cont2monofunE[rotated])
    apply (intro cont_compose[OF fmap_expand_cont] cont2cont_heapToEnv assms) apply assumption
    done

lemma HSem_cont'':
  assumes cont: "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  assumes cond1: "HSem_cond' h (\<Squnion> i. Y i)"
  assumes cond2: "\<And>i. HSem_cond' h (Y i)"
  assumes "chain Y"
  shows "HSem h (\<Squnion> i. Y  i) = (\<Squnion> i. HSem h (Y i))"
proof-
  have fdoms[simp]:"\<And> i. fdom (Y i) = fdom (\<Squnion> i. Y i)" (is "\<And> _ .(_ = ?d)") by (metis chain_fdom `chain Y`)

  have "fix_on       (fix_join_compat (\<Squnion> i. Y i\<^bsub>[?d \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>))
             (\<lambda>\<rho>'.                     (\<Squnion> i. Y i\<^bsub>[?d \<union> heapVars h]\<^esub>) \<squnion>
                      heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>) =
       (\<Squnion> i. fix_on  (fix_join_compat      (Y i\<^bsub>[?d \<union> heapVars h]\<^esub>)  (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>))
                                        (\<lambda>\<rho>'. Y i\<^bsub>[?d \<union> heapVars h]\<^esub> \<squnion>
                      heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>)) "
    by (rule fix_on_join_cont[OF
          ch2ch_cont[OF fmap_expand_cont `chain Y`]
          cond2[unfolded fdoms]
          cond1[unfolded cont2contlubE[OF fmap_expand_cont `chain Y`]]
          ])
  thus ?thesis
    unfolding HSem_def
    unfolding if_P[OF cond1] if_P[OF cond2]
    by (simp add: cont2contlubE[OF fmap_expand_cont `chain Y`])
qed

subsubsection {* Disjoint heaps and environments are compatible *}

lemma disjoint_is_HSem_cond':
  "fdom \<rho> \<inter> heapVars h = {} \<Longrightarrow> (\<forall> e \<in> snd`set h. cont (ESem e)) \<Longrightarrow> HSem_cond' h \<rho>"
  apply (rule fix_join_condI)
  apply (rule cont_compose[OF fmap_expand_cont cont2cont_heapToEnv])
  apply (metis)
  apply (rule compatible_fmapI)
  apply (case_tac "x \<in> fdom \<rho>")
  apply simp
  apply (subst lookup_fmap_expand2)
  apply auto
  done

subsubsection {* Inductions over the heap semantics *}

lemma HSem_ind':
  assumes "HSem_cond' h \<rho>"
  assumes "adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)) P"
  assumes "P (to_bot (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"
  assumes "\<And> y. y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
        P y \<Longrightarrow>
        P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  shows "P (HSem h \<rho>)"
  unfolding HSem_def
  apply (subst if_P[OF assms(1)])
  apply (rule fix_on_fjc_ind[OF assms(1)])
  apply fact
  apply (simp add:bottom_of_fjc)
  apply fact
  apply fact
  done

lemma HSem_ind:
  assumes "HSem_cond' h \<rho> \<Longrightarrow> adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)) P"
  assumes "HSem_cond' h \<rho> \<Longrightarrow> P (to_bot (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"
  assumes "\<And> y. HSem_cond' h \<rho> \<Longrightarrow>
        y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
        P y \<Longrightarrow>
        P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  assumes "P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  shows "P (HSem h \<rho>)"
  apply (cases "HSem_cond' h \<rho>")
  apply (rule HSem_ind'[OF _ assms(1,2,3)], assumption+)
  unfolding HSem_def
  apply (subst if_not_P, assumption)
  apply (rule assms(4))
  done

lemma parallel_HSem_ind:
  assumes cond1: "HSem_cond' h \<rho>"
  assumes cond2: "HSem_cond' h2 \<rho>2"
  assumes "adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
                  \<times> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>))
                 (\<lambda>\<rho>'. P (fst \<rho>') (snd \<rho>'))"
  assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (f\<emptyset>\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)"
  assumes "\<And>y z. y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
          z \<in> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) \<Longrightarrow>
          P y z \<Longrightarrow>
          P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
           (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub> \<squnion> heapToEnv h2 (\<lambda>e. ESem e z)\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) "
  shows "P (HSem h \<rho>) (HSem h2 \<rho>2)"
  unfolding HSem_def if_P[OF cond1] if_P[OF cond2]
  apply (rule parallel_fix_on_ind[OF fix_on_cond_fjc[OF cond1] fix_on_cond_fjc[OF cond2]])
  apply (rule assms(3))
  using assms(4) apply (simp add: bottom_of_fjc to_bot_fmap_def)
  by (rule assms(5))

lemma HSem_eq:
  assumes "HSem_cond' h \<rho>"
  shows "HSem h \<rho> = \<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e (HSem h \<rho>))\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>"
  unfolding HSem_def
  using assms
  apply (simp)
  apply (erule fix_on_fjc_eq)
  done

lemma HSem_there:
  assumes "HSem_cond' h \<rho>"
  shows "HSem h \<rho> \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  unfolding HSem_def
  apply (subst if_P[OF assms])
  apply (rule fix_on_there[OF fix_on_cond_fjc[OF assms]])
  done

lemma the_lookup_HSem_other:
  assumes "y \<notin> heapVars h"
  shows "(HSem h \<rho>) f! y = \<rho> f! y"
proof(cases "HSem_cond' h \<rho>")
  case True show ?thesis
    apply (subst HSem_eq[OF True])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF True HSem_there[OF True]]])
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms lookup_not_fdom)
    done
next
  case False show ?thesis
    unfolding HSem_def if_not_P[OF False]
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms  False lookup_not_fdom)
    done
qed

lemma the_lookup_HSem_both:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  shows "HSem h \<rho> f! y =
    (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> f! y) \<squnion> ESem (the (map_of h y)) (HSem h \<rho>)"
  apply (subst HSem_eq[OF assms(1)])
  apply (subst the_lookup_join[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]]])
  apply (subst (2) lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst lookupHeapToEnv[OF assms(2)])
  by (rule refl)

lemma the_lookup_HSem_both_compatible:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  shows "compatible (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> f! y) (ESem (the (map_of h y)) (HSem h \<rho>))"
  using the_lookup_compatible[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]], of y]
  apply (subst (asm) (2) lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst (asm) lookupHeapToEnv[OF assms(2)])
  .

lemma the_lookup_HSem_heap:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  assumes "y \<notin> fdom \<rho>"
  shows "(HSem h \<rho>) f! y = ESem (the (map_of h y)) (HSem h \<rho>)"
  apply (subst HSem_eq[OF assms(1)])
  apply (subst the_lookup_join[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]]])
  apply (subst lookup_fmap_expand2)
    using assms(2,3) apply auto[3]
  apply (subst lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst lookupHeapToEnv[OF assms(2)])
  by (simp)

lemma HSem_refines:
  assumes "HSem_cond' h \<rho>"
  shows "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> HSem h \<rho>"
  apply (subst HSem_eq[OF assms(1)])
  apply (rule join_above1[OF rho_F_compat_fjc[OF assms HSem_there[OF assms]]])
done

lemma HSem_compatible[simp]:
  "compatible (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>) (HSem \<Gamma> \<rho>)"
  apply (cases "HSem_cond' \<Gamma> \<rho>")
  apply (drule HSem_refines)
  apply (metis below.r_refl ub_implies_compatible)
  unfolding HSem_def
  apply simp
  done

lemma fdom_HSem[simp]:
  "fdom (HSem h \<rho>) = fdom \<rho> \<union> heapVars h"
  apply (rule HSem_ind)
  apply (rule adm_is_adm_on)
  apply simp
  apply simp
  apply (subst fdom_join)

  apply (rule compat_fjc)
  apply (erule rho_fjc)
  apply (erule (1) F_pres_compat'')
  apply simp+
  done

lemma HSem_cond'_cong[fundef_cong]:
  "\<lbrakk> env1 = env2 ; heap1 = heap2 ; (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem e = ESem e) \<rbrakk>
      \<Longrightarrow>  HSem_cond' heap1 env1 \<longleftrightarrow> HSem_cond'  heap2 env2"
  by (auto cong:heapToEnv_cong)

lemma HSem_cong[fundef_cong]:
  "\<lbrakk> env1 = env2 ; heap1 = heap2 ; (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem e = ESem e) \<rbrakk>
      \<Longrightarrow> HSem heap1 env1 = HSem heap2 env2"
  unfolding HSem_def
  by (auto cong:heapToEnv_cong)

subsubsection {* Adding a fresh variable to a heap does not affect its semantics *}

lemma HSem_add_fresh:
  assumes cond1: "HSem_cond' \<Gamma> \<rho>"
  assumes cond2: "HSem_cond' ((x,e) # \<Gamma>) \<rho>"
  assumes fresh: "atom x \<sharp> (\<rho>,\<Gamma>)"
  assumes step: "\<And>e \<rho>'. fdom \<rho>' = fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>) \<Longrightarrow> e \<in> snd ` set \<Gamma> \<Longrightarrow> ESem e \<rho>' = ESem e (fmap_restr (fdom \<rho>' - {x}) \<rho>')"
  shows  "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (HSem ((x, e) # \<Gamma>) \<rho>) = HSem \<Gamma> \<rho>"
proof (rule parallel_HSem_ind[OF cond1 cond2])
case goal1 show ?case by (auto intro:adm_is_adm_on)
case goal2 show ?case by (auto)[1]
case goal3
  have "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>) = \<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>"
    apply (subst fmap_restr_fmap_expand2)
    by auto
  moreover

  have "x \<notin> fdom \<rho> \<union> heapVars \<Gamma>"
    using fresh
    apply (auto simp add: sharp_Env fresh_Pair)
    by (metis heapVars_not_fresh)
  hence [simp]:"fdom z - {x} = fdom \<rho> \<union> heapVars \<Gamma>"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(2)]
    by auto

  have "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e z)\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)
    =  heapToEnv \<Gamma> (\<lambda>e. ESem e y)\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub> "
    apply (subst fmap_restr_fmap_expand2)
      apply simp
      apply auto[1]
    apply (subst heapToEnv_remove_Cons_fmap_expand[OF _ `x \<notin> fdom \<rho> \<union> heapVars \<Gamma>`])
      apply simp
    apply (rule arg_cong[OF heapToEnv_cong[OF refl]])
    apply (subst step)
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(2)] apply simp
    apply assumption
    using `_ = y`[symmetric]
    apply simp
    done
  ultimately
  show ?case
    apply (subst fmap_restr_join[OF _ rho_F_compat_fjc[OF cond2 `z \<in> _`]])
    by simp+
qed

lemma fjc'_of_member:
  assumes "fix_join_cond \<rho> F"
  assumes "\<rho>' \<in> fix_join_compat \<rho> F" (is "_ \<in> ?S")
  assumes "to_bot \<rho> = to_bot \<rho>'"
  shows "fix_join_cond \<rho>' F"
proof (rule fix_join_condI)
case goal1
  have "cont F" by (rule cont_F_fjc[OF assms(1)])
  thus ?case by simp
case (goal2 i)
  show ?case
  apply (rule compat_fjc[OF assms(2) F_pres_compat''[OF assms(1)]])

  apply (induct_tac i)
  apply (simp only: funpow.simps id_apply fjc_iff)
  apply (rule to_bot_belowI)
  apply (simp add: assms(3))

  apply (simp only: funpow.simps o_apply id_apply)
  apply (erule join_fjc[OF assms(2) F_pres_compat''[OF assms(1)]])
  done
qed

lemma fjc'_of_fun_below:
  fixes \<rho> :: "'a\<Colon>{Bounded_Nonempty_Meet_cpo,subpcpo_partition}"
  assumes "fix_join_cond \<rho> F"
  assumes "G \<sqsubseteq> F"
  assumes "cont G"
  shows "fix_join_cond \<rho> G"
  apply (rule fix_join_condI[OF assms(3)])
  apply (rule compat_fjc[OF rho_fjc[OF assms(1)]])
  apply (rule down_closed_fjc[OF _ fun_belowD[OF assms(2)]])
  apply (rule F_pres_compat''[OF assms(1)])

  apply (induct_tac i)
  apply (simp only: funpow.simps id_apply fjc_iff)
  apply (rule to_bot_belowI)
  apply (simp add: assms(3))

  apply (simp only: funpow.simps o_apply id_apply)
  apply (rule join_fjc[OF rho_fjc[OF assms(1)]])
  apply (rule down_closed_fjc[OF _ fun_belowD[OF assms(2)]])
  apply (erule F_pres_compat''[OF assms(1)])
  done

lemma HSem_cond'_of_member:
  assumes "HSem_cond' \<Gamma> \<rho>"
  assumes "\<rho>' \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)
                (\<lambda> \<rho>'.  heapToEnv \<Gamma> (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)" (is "_ \<in> ?S")
  shows "HSem_cond' \<Gamma>  \<rho>'"
proof-
  let "fix_join_compat (\<rho>\<^bsub>[?d]\<^esub>) ?F" = "?S"
  have "fdom \<rho>' = ?d"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF assms(1)] assms(2)]
    by auto
  have fdom[simp]:"fdom \<rho>' \<union> heapVars \<Gamma> = ?d"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF assms(1)] assms(2)]
    by auto
  show ?thesis
    apply (rule fjc'_of_member)
    apply (rule assms(1)[unfolded fdom[symmetric]])
    apply (subst fmap_expand_noop)
    apply (metis `fdom \<rho>' = fdom \<rho> \<union> heapVars \<Gamma>` `fdom \<rho>' \<union> heapVars \<Gamma> =fdom \<rho> \<union> heapVars \<Gamma>`)
    apply (rule assms(2)[unfolded fdom[symmetric]])
    apply (simp add:to_bot_fmap_def)
    done
qed

subsubsection {* Reordering lemmas for HSem *}

lemma HSem_reorder:
  assumes "distinctVars \<Gamma>"
  assumes "distinctVars \<Delta>"
  assumes "set \<Gamma> = set \<Delta>"
  shows "HSem \<Gamma> \<rho> = HSem \<Delta> \<rho>"
by (simp add: HSem_def heapVars_def heapToEnv_reorder[OF assms] assms(3))

lemma HSem_reorder_head:
  assumes "x \<noteq> y"
  shows "HSem ((x,e1)#(y,e2)#\<Gamma>) \<rho> = HSem ((y,e2)#(x,e1)#\<Gamma>) \<rho>"
proof-
  have "set ((x,e1)#(y,e2)#\<Gamma>) = set ((y,e2)#(x,e1)#\<Gamma>)"
    by auto
  thus ?thesis
    unfolding HSem_def heapToEnv_reorder_head[OF assms]
    by (simp add: heapVars_def)
qed

lemma HSem_reorder_head_append:
  assumes "x \<notin> heapVars \<Gamma>"
  shows "HSem ((x,e)#\<Gamma>@\<Delta>) \<rho> = HSem (\<Gamma> @ ((x,e)#\<Delta>)) \<rho>"
proof-
  have "set ((x,e)#\<Gamma>@\<Delta>) = set (\<Gamma> @ ((x,e)#\<Delta>))" by auto
  thus ?thesis
    unfolding HSem_def heapToEnv_reorder_head_append[OF assms]
    by simp
qed

subsubsection {* Substitution *}

lemma HSem_subst_exp:
  assumes cond1: "HSem_cond' ((x, e) # \<Gamma>) \<rho>"
  assumes cond2: "HSem_cond' ((x, e') # \<Gamma>) \<rho>"
  assumes "\<And>\<rho>'. fdom \<rho>' = fdom \<rho> \<union> (heapVars ((x,e)#\<Gamma>)) \<Longrightarrow> ESem e \<rho>' = ESem e' \<rho>'"
  shows "HSem ((x,e)#\<Gamma>) \<rho> = HSem ((x,e')#\<Gamma>) \<rho>"
  apply (rule parallel_HSem_ind[OF cond1 cond2])
  apply (auto intro: adm_is_adm_on)[1]
  apply simp
  apply (subst heapToEnv_subst_exp)
  apply (rule assms(3))
  apply (drule fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond1]])
  apply simp
  apply simp
  done

subsubsection {* Refinement relations *}

lemma HSem_refines_lookup: "HSem_cond' \<Gamma> \<rho> \<Longrightarrow> x \<in> fdom \<rho> \<Longrightarrow> \<rho> f! x \<sqsubseteq> (HSem \<Gamma> \<rho>) f! x"
  apply (drule HSem_refines)
  apply (drule fmap_belowE[of _ _ x])
  apply simp
  done

lemma HSem_heap_below: "HSem_cond' \<Gamma> \<rho> \<Longrightarrow> x \<in> heapVars \<Gamma> \<Longrightarrow> ESem (the (map_of \<Gamma> x)) (HSem \<Gamma> \<rho>) \<sqsubseteq> (HSem \<Gamma> \<rho>) f! x"
  apply (subst the_lookup_HSem_both, assumption+)
  apply (rule join_above2)
  apply (rule the_lookup_HSem_both_compatible, assumption+)
  done

lemma fmap_restr_HSem_noop:
  assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
  shows "fmap_restr (fdom \<rho>) (HSem \<Gamma> \<rho>) = \<rho>"
  apply (rule fmap_eqI)
  using assms apply auto[1]
  using assms apply auto[1]
  apply (subst the_lookup_HSem_other)
  apply auto
  done

lemma HSem_disjoint_less:
  assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
  shows "\<rho> \<le> HSem \<Gamma> \<rho>"
  using assms
by (metis fmap_less_restrict fmap_restr_HSem_noop)
end

subsubsection {* Requiring continuity of the expression semantics *}

text {*
The lemmas above ought to be sufficient to prove continuity of the expression semantics. Hence, we
extend the locale by assuming this for alle expressions, and repeat some of the lemmas above, discharing
their more specific assumptions.
*}

locale has_cont_ESem = has_ESem +
  assumes ESem_cont: "\<And> e. cont (ESem e)"
begin
  lemma HSem_below:
    assumes "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> r"
    assumes "\<And>x. x \<in> heapVars h \<Longrightarrow> ESem (the (map_of h x)) r \<sqsubseteq> r f! x"
    shows "HSem h \<rho> \<sqsubseteq> r"
  proof (rule HSem_ind)
    from fmap_below_dom[OF assms(1)]
    have [simp]:"fdom r = fdom \<rho> \<union> heapVars h" by simp
    {
    case goal1 show ?case by (auto intro: adm_is_adm_on)
    case goal2 show ?case by (simp add: to_bot_fmap_def)
    case (goal3 \<rho>')
      show ?case
      apply (rule join_below[OF rho_F_compat_fjc[OF goal3(1) goal3(2)] assms(1)])
      apply (rule fmap_expand_belowI)
      apply simp
      apply (simp add: lookupHeapToEnv)
      by (rule below_trans[OF
            cont2monofunE[OF ESem_cont goal3(3)]
            assms(2)])
    next
    case goal4 show ?case by fact
    }
  qed

  lemma disjoint_is_HSem_cond:
    "fdom \<rho> \<inter> heapVars h = {} \<Longrightarrow> HSem_cond' h \<rho>"
    apply (erule disjoint_is_HSem_cond')
    apply rule
    apply (rule ESem_cont)
    done

  lemma fempty_is_HSem_cond:
    "HSem_cond' h fempty"
      by (rule disjoint_is_HSem_cond, auto)

  lemma HSem_cond'_Nil[simp]:
    "HSem_cond' [] \<rho>"
    by (rule disjoint_is_HSem_cond, simp)

  lemma HSem_Nil[simp]: "HSem [] \<rho> = \<rho>"
    apply (subst HSem_eq[OF HSem_cond'_Nil])
    apply auto
    by (metis below.r_refl is_joinI to_bot_fmap_def to_bot_minimal)

  lemma HSem_mono:
    assumes "HSem_cond' \<Gamma> \<rho>1"
    assumes "HSem_cond' \<Gamma> \<rho>2"
    assumes "\<rho>1 \<sqsubseteq> \<rho>2"
    shows "HSem \<Gamma> \<rho>1 \<sqsubseteq> HSem \<Gamma> \<rho>2"
    by(rule HSem_monofun''[OF ESem_cont assms])

subsubsection {* Re-calculating the semantics of the heap is idempotent *}

  lemma HSem_redo:
    assumes "HSem_cond' (\<Gamma> @ \<Delta>) \<rho>"
    assumes "HSem_cond' \<Gamma> (fmap_restr (fdom \<rho> \<union> heapVars \<Delta>) (HSem (\<Gamma> @ \<Delta>) \<rho>))"
    shows "HSem \<Gamma> (fmap_restr (fdom \<rho> \<union> heapVars \<Delta>) (HSem (\<Gamma>@\<Delta>) \<rho>)) = HSem (\<Gamma> @ \<Delta>) \<rho>" (is "?LHS = ?RHS")
  proof (rule below_antisym)
    show "?LHS \<sqsubseteq> ?RHS"
    proof(rule HSem_below)
    case goal1
      show ?case
        apply (rule fmap_expand_fmap_restr_below)
        apply auto
        done
    case (goal2 x)
      hence "x \<in> heapVars (\<Gamma>@\<Delta>)" by auto
      show ?case
        apply (subst the_lookup_HSem_both[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`])
        apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`]]])
        using goal2 by (auto simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
    qed

    show "?RHS \<sqsubseteq> ?LHS"
    proof(rule HSem_below)
    case goal1
      show ?case
        apply (rule fmap_expand_belowI)
          apply auto[1]
        apply (rule below_trans[OF _ HSem_refines_lookup[OF assms(2)]])
          prefer 2 apply simp
        apply (subst lookup_fmap_restr)
          apply auto[2]
        apply (erule HSem_refines_lookup[OF assms(1)])
        done

    case (goal2 x)
      show ?case
      proof(cases "x \<in> heapVars \<Gamma>")
      case True
        show ?thesis
          apply (subst the_lookup_HSem_both[OF assms(2) True])
          apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(2) True]]])
          using True by (auto simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
      next
      case False
        hence delta: "x \<in> heapVars \<Delta>" using goal2 by auto
        show ?thesis
          apply (subst the_lookup_HSem_other[OF False])
          apply (subst lookup_fmap_restr)
            using delta apply auto[2]
          apply (subst the_lookup_HSem_both[OF assms(1) goal2])
          apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`]]])
          apply (rule cont2monofunE[OF ESem_cont `?LHS \<sqsubseteq> ?RHS`])
          done
      qed
    qed
  qed

subsubsection {* The heap semantics can also be defined inductively over the heap *}

  lemma iterative_HSem:
    assumes "HSem_cond' ((x, e) # \<Gamma>) \<rho>"
    assumes "x \<notin> heapVars \<Gamma>"
    shows "HSem ((x,e) # \<Gamma>) \<rho> =
        fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>) (\<lambda> \<rho>'. heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>))
                (\<lambda> \<rho>'. (HSem \<Gamma> \<rho>')
                        \<squnion> ((f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)(x f\<mapsto> ESem e \<rho>')
                        \<squnion> (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)))" (is "_ = fix_on ?S ?R")
  apply (subst HSem_def'[OF assms(1)])
  proof(rule below_antisym)
    let ?closed_on = "subpcpo_syn.closed_on ?S"
    let ?cont_on = "subpcpo_syn.cont_on ?S"
    let ?bottom_of = "subpcpo_syn.bottom_of ?S"
    interpret subpcpo ?S by (rule subpcpo_fjc)

    let "?d" = "fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)"

    let "fix_on _ ?L" = "fix_on ?S
                         (\<lambda>\<rho>'. \<rho>\<^bsub>[?d]\<^esub> \<squnion>
                               heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)"
    let "(\<lambda> \<rho>'. ?L1 \<rho>' \<squnion> ?L2 \<rho>')" = ?L
    let "(\<lambda> \<rho>'. ?R1 \<rho>' \<squnion> (?R2 \<rho>' \<squnion> ?R3 \<rho>'))" = ?R

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      hence fdom1: "fdom \<rho>' = ?d"
      apply (subst (asm) fjc_iff)
      apply (drule fmap_below_dom)
      apply (subst (asm) fdom_fix_on[OF fix_on_cond_fjc[OF assms(1)], unfolded bottom_of_fjc])
      apply auto
      done
    } note fdom = this

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      have fdom1: "(fdom \<rho>' \<union> heapVars \<Gamma>) = ?d" using fdom[OF `\<rho>' \<in> ?S`] by auto
      have fdom2: "(fdom \<rho>' \<union> heapVars ((x,e) # \<Gamma>)) = ?d" using fdom1 by auto
      have "HSem_cond' ((x,e) # \<Gamma>) \<rho>'" by (rule HSem_cond'_of_member[OF assms(1) `\<rho>'\<in>?S`])
      from this[unfolded fdom2]
      have "HSem_cond' \<Gamma> \<rho>'"
        apply (subst (1 2) fdom1, rule fjc'_of_fun_below)
        apply (rule fun_belowI)
        apply (rule heapToEnv_mono)
        apply simp
        apply rule
        apply (simp add: assms(2))
        apply (rule cont_compose[OF fmap_expand_cont cont2cont_heapToEnv[OF ESem_cont]])
        done
    } note HSem_cond'_Gamma = this

    have closedL: "?closed_on ?L"
      by (rule closed_on_fjc[OF assms(1)])

    have closedR1: "?closed_on ?R1"
      apply (rule closed_onI)
      apply (rule HSem_ind)
      apply (rule adm_is_adm_on[OF subcpo_mem_adm[OF subcpo_fjc]])
      apply (rule down_closed_fjc, assumption)
      apply (frule fdom)
      apply (auto simp add:to_bot_fmap_def simp del:fjc_iff)[1]
      apply (rule join_fjc)
       apply (subst fmap_expand_noop)
       apply (frule fdom, auto)[1]
       apply assumption

      apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption) back
      apply (rule heapToEnv_mono)
      apply simp
      apply (frule fdom, auto)[1]
      apply (simp add: assms(2))
      apply (subst fmap_expand_noop)
      apply (frule fdom, auto)[1]
      apply assumption
      done

    have closedR2: "?closed_on ?R2"
      apply (rule closed_onI)
      apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption)
      apply (rule fmap_belowI)
      apply (frule fdom, auto)[1]
      apply (case_tac "xaa = x", simp_all)
      done

    have closedR3: "?closed_on ?R3"
      apply (rule closed_onI)
      by (rule rho_fjc[OF assms(1)])

    have closedR: "?closed_on ?R"
      by (rule closed_on_join_fjc[OF closedR1 closed_on_join_fjc[OF closedR2 closedR3]])

    have contL: "?cont_on ?L"
      by (rule cont_on_fjc[OF assms(1)])

    have contR1: "?cont_on ?R1"
      apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (2) HSem_monofun''[OF ESem_cont HSem_cond'_Gamma HSem_cond'_Gamma])
      apply (rule eq_imp_below[OF HSem_cont''[OF ESem_cont]])
      apply (erule HSem_cond'_Gamma[OF chain_on_lub_on])
      apply (erule HSem_cond'_Gamma[OF chain_on_is_on])
      apply (erule chain_on_is_chain)
      done

    have contR2: "?cont_on ?R2"
      by (rule cont_is_cont_on[OF fmap_upd_cont[OF cont_const ESem_cont]])

    have contR3: "?cont_on ?R3"
      by (rule cont_is_cont_on[OF cont_const])

    have contR: "?cont_on ?R"
      apply (rule cont_on_join_fjc)
      apply (rule closedR1)
      apply (rule closed_on_join_fjc[OF closedR2 closedR3])
      apply (rule contR1)
      apply (rule cont_on_join_fjc)
      apply (rule closedR2)
      apply (rule closedR3)
      apply (rule contR2)
      apply (rule contR3)
      done

    note fix_on_condL = fix_on_cond_fjc[OF assms(1)]

    have fix_on_condR: "fix_on_cond ?S ?bottom_of ?R"
      by (rule fix_on_condI[OF subpcpo_fjc refl closedR contR])

    have R_there: "fix_on ?S ?R \<in> ?S"
      by (rule fix_on_there[OF fix_on_condR])

    have compatL: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?L1 x) (?L2 x)"
      by (rule compat_fjc[OF rho_fjc[OF assms(1)]  F_pres_compat''[OF assms(1)]])

    have compatR2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR2] closed_onE[OF closedR3]])
    have compatR1R2: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closedR2]])
    have compatR1R2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x \<squnion> ?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closed_on_join_fjc[OF closedR2 closedR3]]])
    have compatR1R2R3': "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x \<squnion> ?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closed_on_join_fjc[OF closedR1 closedR2]] closed_onE[OF closedR3]])

    show "fix_on ?S ?L \<sqsubseteq> fix_on ?S ?R"
    proof (rule fix_on_mono[OF fix_on_condL fix_on_condR])
      fix \<rho>'
      assume there: "\<rho>' \<in> ?S"
      hence [simp]:"fdom \<rho>' = ?d" by (rule fdom)

      have inner_cond: "HSem_cond' \<Gamma> \<rho>'"
        by (rule HSem_cond'_Gamma[OF there])
      have inner_refine: "\<rho>' \<sqsubseteq> HSem \<Gamma> \<rho>'"
        apply (insert HSem_refines[OF inner_cond])
        apply (subst (asm) fmap_expand_noop)
        apply auto
        done

      have belowL1: "?L1 \<rho>' \<sqsubseteq> ?R \<rho>'"
        by (rule below_trans[OF join_above2[OF compatR2R3[OF there]] join_above2[OF compatR1R2R3[OF there]]])

      have "?L2 \<rho>' \<sqsubseteq> ?R1 \<rho>' \<squnion> ?R2 \<rho>'"
      proof (rule fmap_belowI)
      case goal1 show ?case
        by (subst fdom_join[OF compatR1R2[OF there]], auto)
      case (goal2 x')
        hence "x' \<in> ?d" by simp
        show ?case
        proof(cases "x' = x")
        case True
          show ?thesis
            apply (subst the_lookup_join[OF compatR1R2[OF there]])
            apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
            apply (simp add: True)
            apply (erule join_above2)
            done
        next
        case False
          show ?thesis
          proof (cases "x' \<in> heapVars \<Gamma>")
          case True
            have "heapToEnv \<Gamma> (\<lambda>e. ESem e \<rho>') f! x' \<sqsubseteq> HSem \<Gamma> \<rho>' f! x'"
              apply (subst HSem_eq[OF inner_cond])
              apply (subst the_lookup_join[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]]])
              apply (insert the_lookup_compatible[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]], of x'])
              apply (subst (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (subst (asm) (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (erule below_trans[OF _ join_above2, rotated])
              apply (rule cont2monofunE[OF _ inner_refine])
              apply (intro cont2cont ESem_cont)
              done
            thus ?thesis
              apply (subst lookup_fmap_expand1)
              apply simp
              apply (simp add: True)
              apply (simp add: True)
              apply (subst the_lookup_join[OF compatR1R2[OF there]])
              apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
              apply (simp add: True False)
              done
          next
          case False
            show ?thesis
            apply (subst lookup_fmap_expand2)
            apply simp
            apply fact
            apply (simp add: False `x' \<noteq> x`)
            apply simp
            done
          qed
        qed
      qed
      hence belowL2: "?L2 \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (subst join_assoc[symmetric, OF compatR1R2[OF there] compatR1R2R3[OF there] compatR2R3[OF there]])
        apply (erule below_trans[OF _ join_above1[OF compatR1R2R3'[OF there]]])
        done

      show "?L \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (rule join_below[OF compatL[OF there]])
        apply (rule belowL1)
        apply (rule belowL2)
        done
    qed

    show "fix_on ?S ?R \<sqsubseteq> fix_on ?S ?L"
      unfolding bottom_of_fjc
      by (rule R_there[unfolded fjc_iff, unfolded bottom_of_fjc])
  qed

  subsubsection {* Substitution *}

  lemma HSem_subst_expr_below:
    assumes cond1: "HSem_cond' ((x, e1) # \<Gamma>) \<rho>"
    assumes cond2: "HSem_cond' ((x, e2) # \<Gamma>) \<rho>"
    assumes below: "ESem e1 (HSem ((x, e2) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e2 (HSem ((x, e2) # \<Gamma>) \<rho>)"
    shows "HSem ((x, e1) # \<Gamma>) \<rho> \<sqsubseteq> HSem ((x, e2) # \<Gamma>) \<rho>"
  proof (rule HSem_ind'[OF cond1])
  case goal1 show ?case by (auto intro: adm_is_adm_on)
  case goal2 show ?case by (simp add: to_bot_fmap_def)
  case (goal3 \<rho>')
    show ?case
      apply (subst HSem_eq[OF cond2])
      apply (rule join_mono[OF
        rho_F_compat_fjc[OF cond1 goal3(1)]
        rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]
        ])
      apply simp
      apply (subst (1 2) heapToEnv.simps)
      apply (simp del: heapToEnv.simps)
      apply (rule cont2monofunE[OF fmap_expand_cont])
      apply (rule fmap_upd_mono)
      apply (rule cont2monofunE[OF cont2cont_heapToEnv[OF ESem_cont] goal3(2)])
      apply (rule below_trans[OF cont2monofunE[OF ESem_cont goal3(2)] below])
      done
  qed

  lemma HSem_subst_expr:
    assumes cond1: "HSem_cond' ((x, e1) # \<Gamma>) \<rho>"
    assumes cond2: "HSem_cond' ((x, e2) # \<Gamma>) \<rho>"
    assumes below1: "ESem e1 (HSem ((x, e2) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e2 (HSem ((x, e2) # \<Gamma>) \<rho>)"
    assumes below2: "ESem e2 (HSem ((x, e1) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e1 (HSem ((x, e1) # \<Gamma>) \<rho>)"
    shows "HSem ((x, e1) # \<Gamma>) \<rho> = HSem ((x, e2) # \<Gamma>) \<rho>"
    by (metis assms HSem_subst_expr_below below_antisym)
end

subsubsection {* Equivariance of @{term HSem} *}

lemma HSem_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem1 e = ESem2 e); env1 = env2 ; heap1 = heap2  \<rbrakk>
      \<Longrightarrow> has_ESem.HSem ESem1 heap1 env1 = has_ESem.HSem  ESem2 heap2 env2"
  unfolding has_ESem.HSem_def
  by (auto cong:heapToEnv_cong)

lemma HSem_eqvt[eqvt]:
  "\<pi> \<bullet> has_ESem.HSem ESem h \<rho> = has_ESem.HSem (\<pi> \<bullet> ESem) (\<pi> \<bullet> h) (\<pi> \<bullet> \<rho>)"
proof (cases "has_ESem.HSem_cond' ESem h \<rho>")
  case True
  hence True_permuted: "has_ESem.HSem_cond' (\<pi> \<bullet> ESem) (\<pi> \<bullet> h)  (\<pi> \<bullet> \<rho>)"
    by -(drule fix_join_cond_eqvt[where \<pi> = \<pi>], perm_simp, assumption)

  show ?thesis
   unfolding has_ESem.HSem_def
   apply (simp only: if_P[OF True] if_P[OF True_permuted])
   apply (subst fix_on_eqvt[OF fix_on_cond_fjc[OF True]])
   apply (subst bottom_of_eqvt[OF subpcpo_fjc])
   apply (subst fix_join_compat_eqvt[OF True])
   apply perm_simp
   apply rule
   done
next
case False
  hence False_permuted: "\<not> has_ESem.HSem_cond' (\<pi> \<bullet> ESem) (\<pi> \<bullet> h) (\<pi> \<bullet> \<rho>)"
    apply -
    apply rule
    apply (erule notE)
    apply (drule fix_join_cond_eqvt[where \<pi> = "- \<pi>"])
    apply perm_simp
    by (metis (no_types) eqvt_bound pemute_minus_self unpermute_def)
  show ?thesis
   unfolding has_ESem.HSem_def
   apply (simp only: if_not_P[OF False] if_not_P[OF False_permuted])
   apply perm_simp
   apply rule
   done
qed
end


theory NumberWang_IPv4
imports Main
  "HOL-Library.Word"
begin

lemma zdiv_mult_self:
  \<open>m \<noteq> 0 \<Longrightarrow> (a + m * n) div m = a div m + n\<close>
  for a m n :: int
  by simp

section\<open>Helper Lemmas for Low-Level Operations on Machine Words\<close>
text\<open>Needed for IPv4 Syntax\<close>

lemma mod256: "((d::nat) + 256 * c + 65536 * b + 16777216 * a) mod 256 = d mod 256"
proof -
  from mod_mult_self2[where a="d + 256 * c + 65536 * b" and b="256" and c="65536 * a"] have
    "(d + 256 * c + 65536 * b + 256 * 65536 * a) mod 256 = (d + 256 * c + 65536 * b) mod 256"
    by simp
  also have "\<dots>  = (d + 256 * c) mod 256"
    using mod_mult_self2[where a="d + 256 * c" and b="256" and c="256 * b"] by simp
  also have "\<dots> = d mod 256" using mod_mult_self2 by blast
  finally show ?thesis by simp
qed

lemma div65536: assumes "a < 256" "b < 256" "c < 256" "d < 256"
    shows "nat ((int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 mod 256) = b"
proof -
  from zdiv_mult_self[where a="int d + int (256 * c) + int (65536 * b)" and m=65536 and n="256 * (int a)"] have
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 =
     ((int d + int (256 * c) + int (65536 * b)) div 65536) + 256 * int a" by linarith
  also from zdiv_mult_self[where a="int d + int (256 * c)" and m="65536" and n="int b"] have
    "\<dots> = (int d + int (256 * c)) div 65536 + int b + 256 * int a" by linarith
  also from assms have "\<dots> = int b + 256 * int a" by simp
  finally have helper:
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 = int b + 256 * int a" .
  with assms show ?thesis
    by simp
qed

lemma div256: assumes "a < 256" "b < 256" "c < 256" "d < 256"
  shows "nat ((int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 mod 256) = c"
proof -
  from zdiv_mult_self[where a="int d + int (256 * c) + int (65536 * b)" and m=256 and n="65536 * (int a)"] have
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 =
     ((int d + int (256 * c) + int (65536 * b)) div 256) + 65536 * int a" by linarith
  also from zdiv_mult_self[where a="int d + int (256 * c)" and m="256" and n="256 * int b"] have
    "\<dots> = (int d + int (256 * c)) div 256 + 256 * int b + 65536 * int a" by linarith
  also from zdiv_mult_self[where a="int d" and m="256" and n="int c"] have
    "\<dots> = (int d) div 256 + int c + 256 * int b + 65536 * int a" by linarith
  also from assms have "\<dots> = int c + 256 * int b + 65536 * int a" by simp
  finally have helper1: "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 =
                          int c + 256 * int b + 65536 * int a" .

  from mod_mult_self2[where a="int c + 256 * int b" and c="256 * int a" and b=256] have
    "(int c + 256 * int b + 65536 * int a) mod 256 = (int c + 256 * int b) mod 256" by simp
  also have "\<dots> = int c mod 256" using mod_mult_self2[where a="int c" and b=256 and c="int b"] by simp
  also have "\<dots> = int c" using assms
    apply(subst mod_pos_pos_trivial)
    by(simp_all)
  finally have helper2: "(int c + 256 * int b + 65536 * int a) mod 256 = int c" .

  from helper1 helper2 show ?thesis by simp
qed

end


theory specialization
   imports separation
begin

section \<open>Generalized specialization orderings and Alexandrov topologies\<close>

(**A topology is called 'Alexandrov' (after the Russian mathematician Pavel Alexandrov) if the intersection
(resp. union) of any (finite or infinite) family of open (resp. closed) sets is open (resp. closed);
in algebraic terms, this means that the set of fixed points of the interior (closure) operation is closed
under infinite meets (joins). Another common algebraic formulation requires the closure (interior) operation
to satisfy the infinitary variants of additivity (multiplicativity), i.e. iADDI (iMULT) as introduced before.

In the literature, the well-known Kuratowski conditions for the closure (resp. interior) operation are assumed,
namely: ADDI, EXPN, NORM, IDEM (resp. MULT, CNTR, DNRM, IDEM). This makes both formulations equivalent.
However, this is not the case in general if those conditions become negotiable.*)

(**Alexandrov topologies have interesting properties relating them to the semantics of modal logic.
Assuming Kuratowski conditions, Alexandrov topological operations defined on subsets of S are in one-to-one
correspondence with preorders on S; in topological terms, Alexandrov topologies are uniquely determined by
their specialization preorders. Since we do not presuppose any Kuratowski conditions to begin with, the
preorders in question are in general not even transitive. Here we just call them 'specialization relations'.
We will still call (generalized) closure/interior-like operations as such (for lack of a better name).
We explore minimal conditions under which some relevant results for the semantics of modal logic obtain.*)

subsection \<open>Specialization relations\<close>

(**Closure/interior(-like) operators can be derived from an arbitrary relation (as in modal logic)*)
definition Cl_rel::"('w,'w)\<rho> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<C>[_]")
  where "\<C>[R] \<equiv> \<lambda>A. \<lambda>w. \<exists>v. R w v \<and> A v"
definition Int_rel::"('w,'w)\<rho> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<I>[_]")
  where "\<I>[R] \<equiv> \<lambda>A. \<lambda>w. \<forall>v. R w v \<longrightarrow> A v"

(**Duality between interior and closure follows directly:*)
lemma dual_rel1: "\<C>[R] = \<I>[R]\<^sup>d" by (simp add: Cl_rel_def Int_rel_def compl_def op_dual_def setequ_char)
lemma dual_rel2: "\<I>[R] = \<C>[R]\<^sup>d" using dual_rel1 dual_symm op_equal_equ by blast

(**We explore minimal conditions of the specialization relation under which some operation's conditions obtain.*)
lemma rMONO: "MONO \<C>[R]" by (smt (verit, del_insts) Cl_rel_def MONO_def subset_def)
lemma rC1i: "iCl_1 \<C>[R]" unfolding iADDI_def Cl_rel_def img_dir_def supremum_def using setequ_char by fastforce
lemma rC2: "reflexive R \<longrightarrow> Cl_2 \<C>[R]" by (smt (verit, ccfv_threshold) Cl_rel_def EXPN_def reflexive_def subset_def)
lemma rC3: "Cl_3 \<C>[R]" by (simp add: iADDI_NORM rC1i)
lemma rC4: "reflexive R \<and> transitive R \<longrightarrow> Cl_4 \<C>[R]" by (smt (verit, best) Cl_rel_def EXPN_def IDEM_def rC2 setequ_char subset_def transitive_def)

(**A specialization relation can be derived from a given operation (intended as a closure-like operation).*)
definition spec_rel::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w,'w)\<rho>" ("sp[_]")
  where "sp[\<C>] \<equiv> \<lambda>w v. \<C> {v} w"

(**Preorder properties of the specialization relation follow directly from the corresponding operation's conditions.*)
lemma sp_rel_refl: "Cl_2 \<C> \<Longrightarrow> reflexive sp[\<C>]"by (simp add: singleton_def EXPN_def reflexive_def spec_rel_def subset_def)
lemma sp_rel_trans: "MONO \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> transitive sp[\<C>]" unfolding singleton_def transitive_def IDEM_def MONO_def spec_rel_def by (smt (verit, best) setequ_equ subset_def)

(**However, we can obtain finite countermodels for antisymmetry and symmetry given all relevant conditions.
We will revisit this issue later and examine their relation with the topological separation axioms T0 and T1 resp.*)
lemma "iCl_1 \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_3 \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> antisymmetric sp[\<C>]" nitpick oops (*counterexample*)
lemma "iCl_1 \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_3 \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> symmetric sp[\<C>]" nitpick oops (*counterexample*)

subsection \<open>Alexandrov topology\<close>

(**As mentioned previously, Alexandrov closure (and by duality interior) operations correspond to specialization
relations. It is worth mentioning that in Alexandrov topologies every point has a minimal/smallest neighborhood,
namely the set of points related to it by the specialization (aka. accessibility) relation.
We examine below  minimal conditions under which these relations obtain.*)

lemma sp_rel_a:   "MONO \<C>  \<Longrightarrow> \<forall>A. \<C>[sp[\<C>]] A \<preceq> \<C> A" by (smt (verit, best) singleton_def Cl_rel_def MONO_def spec_rel_def subset_def)
lemma sp_rel_b: "iADDI_a \<C> \<Longrightarrow> \<forall>A. \<C>[sp[\<C>]] A \<succeq> \<C> A" proof -
  assume iaddia: "iADDI_a \<C>"
  { fix A::"'a \<sigma>"
    let ?S="\<lambda>B. \<exists>w. A w \<and> B=(\<lambda>u. u=w)"
    have "A \<approx> (\<^bold>\<Or>?S)" by (smt (verit, best) setequ_char supremum_def)
    hence "\<C>(A) \<approx> \<C>(\<^bold>\<Or>?S)" by (simp add: setequ_equ)
    moreover have "\<^bold>\<Or>\<lbrakk>\<C> ?S\<rbrakk> \<approx> \<C>[sp[\<C>]] A" unfolding spec_rel_def singleton_def by (smt (verit) Cl_rel_def img_dir_def setequ_char supremum_def)
    moreover from iaddia have "\<C>(\<^bold>\<Or>?S) \<preceq> \<^bold>\<Or>\<lbrakk>\<C> ?S\<rbrakk>" unfolding iADDI_a_def by simp
    ultimately have "\<C> A \<preceq> \<C>[sp[\<C>]] A" by (simp add: setequ_equ)
  } thus ?thesis by simp
qed
lemma sp_rel: "iCl_1 \<C> \<Longrightarrow> \<C> = \<C>[sp[\<C>]]" by (meson MONO_iADDIb ext iADDI_char setequ_def setequ_equ sp_rel_a sp_rel_b)

(**It is instructive to expand the definitions in the above result:*)
lemma "iCl_1 \<C> \<Longrightarrow>  \<forall>A. \<forall>w. (\<C> A) w \<longleftrightarrow> (\<exists>v. A v \<and> \<C>{v} w)" by (smt (z3) Cl_rel_def singleton_def sp_rel)

(**We now turn to the more traditional characterization of Alexandrov topologies in terms of closure under
infinite joins/meets.*)

(**As shown above, closure (interior) operations derived from relations readily satisfy iADDI (iMULT),
being thus closed under infinite joins (meets).*)
lemma "supremum_closed (fp \<C>[R])" by (simp add: fp_sup_closed_cond1 rC1i)
lemma "infimum_closed  (fp \<I>[R::('w,'w)\<rho>])" by (simp add: dual_rel2 fp_sup_closed_cond1 fp_sup_inf_closed_dual rC1i)

subsection \<open>(Anti)symmetry and the separation axioms T0 and T1\<close>
(**We can now revisit the relationship between (anti)symmetry and the separation axioms T1 and T0.*)

(**Under appropriate conditions, T0-separation corresponds to antisymmetry of the specialization relation (here an ordering).*)
lemma "T0 \<C> \<longleftrightarrow> antisymmetric sp[\<C>]" nitpick oops (*counterexample*)
lemma T0_antisymm_a: "MONO \<C> \<Longrightarrow> T0 \<C> \<longrightarrow> antisymmetric sp[\<C>]"
  unfolding T0_def antisymmetric_def using sp_rel_a Cl_rel_def by (smt (z3) compl_def fixpoint_pred_def op_dual_def setequ_char subset_def)
lemma T0_antisymm_b: "Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> antisymmetric sp[\<C>] \<longrightarrow> T0 \<C>" by (metis (full_types) Cl_Closed EXPN_def IDEM_a_def IDEM_char T0_def2 antisymmetric_def reflexive_def sp_rel_refl spec_rel_def)
lemma T0_antisymm: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> T0 \<C> = antisymmetric sp[\<C>]" by (metis T0_antisymm_a T0_antisymm_b)

(**Also, under the appropriate conditions, T1-separation corresponds to symmetry of the specialization relation.*)
lemma T1_symm_a: "MONO \<C> \<Longrightarrow> T1 \<C> \<longrightarrow> symmetric sp[\<C>]" by (smt (verit) Cl_rel_def T1_def2 fixpoint_pred_def setequ_char sp_rel_a subset_def symmetric_def)
lemma T1_symm_b: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T0 \<C> \<Longrightarrow> symmetric sp[\<C>] \<longrightarrow> T1 \<C>" using T0_antisymm_a sp_rel_refl unfolding T1_def3 fixpoint_pred_def singleton_def antisymmetric_def reflexive_def symmetric_def spec_rel_def singleton_def by (smt (verit) setequ_char)
lemma T1_symm: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T0 \<C> \<Longrightarrow> symmetric sp[\<C>] = T1 \<C>" by (metis T1_symm_a T1_symm_b)

end