(*  Title:      HOL/ex/Tarski.thy
    Author:     Florian Kammüller, Cambridge University Computer Laboratory
*)

section \<open>The Full Theorem of Tarski\<close>

theory Tarski
imports Main "HOL-Library.FuncSet"
begin

text \<open>
  Minimal version of lattice theory plus the full theorem of Tarski:
  The fixedpoints of a complete lattice themselves form a complete
  lattice.

  Illustrates first-class theories, using the Sigma representation of
  structures.  Tidied and converted to Isar by lcp.
\<close>

record 'a potype =
  pset  :: "'a set"
  order :: "('a \<times> 'a) set"

definition monotone :: "['a \<Rightarrow> 'a, 'a set, ('a \<times> 'a) set] \<Rightarrow> bool"
  where "monotone f A r \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> r \<longrightarrow> (f x, f y) \<in> r)"

definition least :: "['a \<Rightarrow> bool, 'a potype] \<Rightarrow> 'a"
  where "least P po = (SOME x. x \<in> pset po \<and> P x \<and> (\<forall>y \<in> pset po. P y \<longrightarrow> (x, y) \<in> order po))"

definition greatest :: "['a \<Rightarrow> bool, 'a potype] \<Rightarrow> 'a"
  where "greatest P po = (SOME x. x \<in> pset po \<and> P x \<and> (\<forall>y \<in> pset po. P y \<longrightarrow> (y, x) \<in> order po))"

definition lub :: "['a set, 'a potype] \<Rightarrow> 'a"
  where "lub S po = least (\<lambda>x. \<forall>y\<in>S. (y, x) \<in> order po) po"

definition glb :: "['a set, 'a potype] \<Rightarrow> 'a"
  where "glb S po = greatest (\<lambda>x. \<forall>y\<in>S. (x, y) \<in> order po) po"

definition isLub :: "['a set, 'a potype, 'a] \<Rightarrow> bool"
  where "isLub S po =
    (\<lambda>L. L \<in> pset po \<and> (\<forall>y\<in>S. (y, L) \<in> order po) \<and>
      (\<forall>z\<in>pset po. (\<forall>y\<in>S. (y, z) \<in> order po) \<longrightarrow> (L, z) \<in> order po))"

definition isGlb :: "['a set, 'a potype, 'a] \<Rightarrow> bool"
  where "isGlb S po =
    (\<lambda>G. (G \<in> pset po \<and> (\<forall>y\<in>S. (G, y) \<in> order po) \<and>
      (\<forall>z \<in> pset po. (\<forall>y\<in>S. (z, y) \<in> order po) \<longrightarrow> (z, G) \<in> order po)))"

definition "fix" :: "['a \<Rightarrow> 'a, 'a set] \<Rightarrow> 'a set"
  where "fix f A  = {x. x \<in> A \<and> f x = x}"

definition interval :: "[('a \<times> 'a) set, 'a, 'a] \<Rightarrow> 'a set"
  where "interval r a b = {x. (a, x) \<in> r \<and> (x, b) \<in> r}"

definition Bot :: "'a potype \<Rightarrow> 'a"
  where "Bot po = least (\<lambda>x. True) po"

definition Top :: "'a potype \<Rightarrow> 'a"
  where "Top po = greatest (\<lambda>x. True) po"

definition PartialOrder :: "'a potype set"
  where "PartialOrder = {P. refl_on (pset P) (order P) \<and> antisym (order P) \<and> trans (order P)}"

definition CompleteLattice :: "'a potype set"
  where "CompleteLattice =
    {cl. cl \<in> PartialOrder \<and>
      (\<forall>S. S \<subseteq> pset cl \<longrightarrow> (\<exists>L. isLub S cl L)) \<and>
      (\<forall>S. S \<subseteq> pset cl \<longrightarrow> (\<exists>G. isGlb S cl G))}"

definition CLF_set :: "('a potype \<times> ('a \<Rightarrow> 'a)) set"
  where "CLF_set =
    (SIGMA cl : CompleteLattice.
      {f. f \<in> pset cl \<rightarrow> pset cl \<and> monotone f (pset cl) (order cl)})"

definition induced :: "['a set, ('a \<times> 'a) set] \<Rightarrow> ('a \<times> 'a) set"
  where "induced A r = {(a, b). a \<in> A \<and> b \<in> A \<and> (a, b) \<in> r}"

definition sublattice :: "('a potype \<times> 'a set) set"
  where "sublattice =
    (SIGMA cl : CompleteLattice.
      {S. S \<subseteq> pset cl \<and> \<lparr>pset = S, order = induced S (order cl)\<rparr> \<in> CompleteLattice})"

abbreviation sublat :: "['a set, 'a potype] \<Rightarrow> bool"  ("_ <<= _" [51, 50] 50)
  where "S <<= cl \<equiv> S \<in> sublattice `` {cl}"

definition dual :: "'a potype \<Rightarrow> 'a potype"
  where "dual po = \<lparr>pset = pset po, order = converse (order po)\<rparr>"

locale S =
  fixes cl :: "'a potype"
    and A :: "'a set"
    and r :: "('a \<times> 'a) set"
  defines A_def: "A \<equiv> pset cl"
     and r_def: "r \<equiv> order cl"

locale PO = S +
  assumes cl_po: "cl \<in> PartialOrder"

locale CL = S +
  assumes cl_co: "cl \<in> CompleteLattice"

sublocale CL < po?: PO
  unfolding A_def r_def
  using CompleteLattice_def PO.intro cl_co by fastforce

locale CLF = S +
  fixes f :: "'a \<Rightarrow> 'a"
    and P :: "'a set"
  assumes f_cl:  "(cl, f) \<in> CLF_set"
  defines P_def: "P \<equiv> fix f A"

sublocale CLF < cl?: CL
  unfolding A_def r_def CL_def
  using CLF_set_def f_cl by blast

locale Tarski = CLF +
  fixes Y :: "'a set"
    and intY1 :: "'a set"
    and v :: "'a"
  assumes Y_ss: "Y \<subseteq> P"
  defines intY1_def: "intY1 \<equiv> interval r (lub Y cl) (Top cl)"
    and v_def: "v \<equiv>
      glb {x. ((\<lambda>x \<in> intY1. f x) x, x) \<in> induced intY1 r \<and> x \<in> intY1}
        \<lparr>pset = intY1, order = induced intY1 r\<rparr>"

subsection \<open>Partial Order\<close>

context PO
begin

lemma dual: "PO (dual cl)"
proof
  show "dual cl \<in> PartialOrder"
  using cl_po unfolding PartialOrder_def dual_def by auto
qed

lemma PO_imp_refl_on [simp]: "refl_on A r"
  using cl_po by (simp add: PartialOrder_def A_def r_def)

lemma PO_imp_sym [simp]: "antisym r"
  using cl_po by (simp add: PartialOrder_def r_def)

lemma PO_imp_trans [simp]: "trans r"
  using cl_po by (simp add: PartialOrder_def r_def)

lemma reflE: "x \<in> A \<Longrightarrow> (x, x) \<in> r"
  using cl_po by (simp add: PartialOrder_def refl_on_def A_def r_def)

lemma antisymE: "\<lbrakk>(a, b) \<in> r; (b, a) \<in> r\<rbrakk> \<Longrightarrow> a = b"
  using cl_po by (simp add: PartialOrder_def antisym_def r_def)

lemma transE: "\<lbrakk>(a, b) \<in> r; (b, c) \<in> r\<rbrakk> \<Longrightarrow> (a, c) \<in> r"
  using cl_po by (simp add: PartialOrder_def r_def) (unfold trans_def, fast)

lemma monotoneE: "\<lbrakk>monotone f A r; x \<in> A; y \<in> A; (x, y) \<in> r\<rbrakk> \<Longrightarrow> (f x, f y) \<in> r"
  by (simp add: monotone_def)

lemma po_subset_po:
  assumes "S \<subseteq> A" shows "\<lparr>pset = S, order = induced S r\<rparr> \<in> PartialOrder"
proof -
  have "refl_on S (induced S r)"
    using \<open>S \<subseteq> A\<close> by (auto simp: refl_on_def induced_def intro: reflE)
  moreover
  have "antisym (induced S r)"
    by (auto simp add: antisym_def induced_def intro: antisymE)
  moreover
  have "trans (induced S r)"
    by (auto simp add: trans_def induced_def intro: transE)
  ultimately show ?thesis
    by (simp add: PartialOrder_def)
qed

lemma indE: "\<lbrakk>(x, y) \<in> induced S r; S \<subseteq> A\<rbrakk> \<Longrightarrow> (x, y) \<in> r"
  by (simp add: induced_def)

lemma indI: "\<lbrakk>(x, y) \<in> r; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> (x, y) \<in> induced S r"
  by (simp add: induced_def)

end

lemma (in CL) CL_imp_ex_isLub: "S \<subseteq> A \<Longrightarrow> \<exists>L. isLub S cl L"
  using cl_co by (simp add: CompleteLattice_def A_def)

declare (in CL) cl_co [simp]

lemma isLub_lub: "(\<exists>L. isLub S cl L) \<longleftrightarrow> isLub S cl (lub S cl)"
  by (simp add: lub_def least_def isLub_def some_eq_ex [symmetric])

lemma isGlb_glb: "(\<exists>G. isGlb S cl G) \<longleftrightarrow> isGlb S cl (glb S cl)"
  by (simp add: glb_def greatest_def isGlb_def some_eq_ex [symmetric])

lemma isGlb_dual_isLub: "isGlb S cl = isLub S (dual cl)"
  by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma isLub_dual_isGlb: "isLub S cl = isGlb S (dual cl)"
  by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma (in PO) dualPO: "dual cl \<in> PartialOrder"
  using cl_po by (simp add: PartialOrder_def dual_def)

lemma Rdual:
  assumes major: "\<And>S. S \<subseteq> A \<Longrightarrow> \<exists>L. isLub S po L" and "S \<subseteq> A" and "A = pset po"
  shows "\<exists>G. isGlb S po G"
proof
  show "isGlb S po (lub {y \<in> A. \<forall>k\<in>S. (y, k) \<in> order po} po)"
    using major [of "{y. y \<in> A \<and> (\<forall>k \<in> S. (y, k) \<in> order po)}"] \<open>S \<subseteq> A\<close> \<open>A = pset po\<close>
    apply (simp add: isLub_lub isGlb_def)
    apply (auto simp add: isLub_def)
    done
qed

lemma lub_dual_glb: "lub S cl = glb S (dual cl)"
  by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma glb_dual_lub: "glb S cl = lub S (dual cl)"
  by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma CL_subset_PO: "CompleteLattice \<subseteq> PartialOrder"
  by (auto simp: PartialOrder_def CompleteLattice_def)

lemmas CL_imp_PO = CL_subset_PO [THEN subsetD]

context CL
begin

lemma CO_refl_on: "refl_on A r"
  by (rule PO_imp_refl_on)

lemma CO_antisym: "antisym r"
  by (rule PO_imp_sym)

lemma CO_trans: "trans r"
  by (rule PO_imp_trans)

end

lemma CompleteLatticeI:
  "\<lbrakk>po \<in> PartialOrder; \<forall>S. S \<subseteq> pset po \<longrightarrow> (\<exists>L. isLub S po L);
     \<forall>S. S \<subseteq> pset po \<longrightarrow> (\<exists>G. isGlb S po G)\<rbrakk>
    \<Longrightarrow> po \<in> CompleteLattice"
  unfolding CompleteLattice_def by blast

lemma (in CL) CL_dualCL: "dual cl \<in> CompleteLattice"
  using cl_co
  apply (simp add: CompleteLattice_def dual_def)
  apply (simp add: dualPO flip: dual_def isLub_dual_isGlb isGlb_dual_isLub)
  done

context PO
begin

lemma dualA_iff [simp]: "pset (dual cl) = pset cl"
  by (simp add: dual_def)

lemma dualr_iff [simp]: "(x, y) \<in> (order (dual cl)) \<longleftrightarrow> (y, x) \<in> order cl"
  by (simp add: dual_def)

lemma monotone_dual:
  "monotone f (pset cl) (order cl) \<Longrightarrow> monotone f (pset (dual cl)) (order(dual cl))"
  by (simp add: monotone_def)

lemma interval_dual: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> interval r x y = interval (order(dual cl)) y x"
  unfolding interval_def dualr_iff by (auto simp flip: r_def)

lemma interval_not_empty: "interval r a b \<noteq> {} \<Longrightarrow> (a, b) \<in> r"
  by (simp add: interval_def) (use transE in blast)

lemma interval_imp_mem: "x \<in> interval r a b \<Longrightarrow> (a, x) \<in> r"
  by (simp add: interval_def)

lemma left_in_interval: "\<lbrakk>a \<in> A; b \<in> A; interval r a b \<noteq> {}\<rbrakk> \<Longrightarrow> a \<in> interval r a b"
  using interval_def interval_not_empty reflE by fastforce

lemma right_in_interval: "\<lbrakk>a \<in> A; b \<in> A; interval r a b \<noteq> {}\<rbrakk> \<Longrightarrow> b \<in> interval r a b"
  by (simp add: A_def PO.dual PO.left_in_interval PO_axioms interval_dual)

end

subsection \<open>sublattice\<close>

lemma (in PO) sublattice_imp_CL:
  "S <<= cl \<Longrightarrow> \<lparr>pset = S, order = induced S r\<rparr> \<in> CompleteLattice"
  by (simp add: sublattice_def CompleteLattice_def r_def)

lemma (in CL) sublatticeI:
  "\<lbrakk>S \<subseteq> A; \<lparr>pset = S, order = induced S r\<rparr> \<in> CompleteLattice\<rbrakk> \<Longrightarrow> S <<= cl"
  by (simp add: sublattice_def A_def r_def)

lemma (in CL) dual: "CL (dual cl)"
proof
  show "dual cl \<in> CompleteLattice"
  using cl_co
  by (simp add: CompleteLattice_def dualPO flip: isGlb_dual_isLub isLub_dual_isGlb)
qed

subsection \<open>lub\<close>

context CL
begin

lemma lub_unique: "\<lbrakk>S \<subseteq> A; isLub S cl x; isLub S cl L\<rbrakk> \<Longrightarrow> x = L"
  by (rule antisymE) (auto simp add: isLub_def r_def)

lemma lub_upper:
  assumes "S \<subseteq> A" "x \<in> S" shows "(x, lub S cl) \<in> r"
proof -
  obtain L where "isLub S cl L"
    using CL_imp_ex_isLub \<open>S \<subseteq> A\<close> by auto
  then show ?thesis
    by (metis assms(2) isLub_def isLub_lub r_def)
qed

lemma lub_least:
  assumes "S \<subseteq> A" and L: "L \<in> A" "\<forall>x \<in> S. (x, L) \<in> r" shows "(lub S cl, L) \<in> r"
proof -
  obtain L' where "isLub S cl L'"
    using CL_imp_ex_isLub \<open>S \<subseteq> A\<close> by auto
  then show ?thesis
    by (metis A_def L isLub_def isLub_lub r_def)
qed

lemma lub_in_lattice:
  assumes "S \<subseteq> A" shows "lub S cl \<in> A"
proof -
  obtain L where "isLub S cl L"
    using CL_imp_ex_isLub \<open>S \<subseteq> A\<close> by auto
  then show ?thesis
    by (metis A_def isLub_def isLub_lub)
qed

lemma lubI:
  assumes A: "S \<subseteq> A" "L \<in> A" and r: "\<forall>x \<in> S. (x, L) \<in> r"
     and clo: "\<And>z. \<lbrakk>z \<in> A; (\<forall>y \<in> S. (y, z) \<in> r)\<rbrakk> \<Longrightarrow> (L, z) \<in> r"
   shows "L = lub S cl"
proof -
  obtain L where "isLub S cl L"
    using CL_imp_ex_isLub assms(1) by auto
  then show ?thesis
    by (simp add: antisymE A clo lub_in_lattice lub_least lub_upper r)
qed

lemma lubIa: "\<lbrakk>S \<subseteq> A; isLub S cl L\<rbrakk> \<Longrightarrow> L = lub S cl"
  by (meson isLub_lub lub_unique)

lemma isLub_in_lattice: "isLub S cl L \<Longrightarrow> L \<in> A"
  by (simp add: isLub_def  A_def)

lemma isLub_upper: "\<lbrakk>isLub S cl L; y \<in> S\<rbrakk> \<Longrightarrow> (y, L) \<in> r"
  by (simp add: isLub_def r_def)

lemma isLub_least: "\<lbrakk>isLub S cl L; z \<in> A; \<forall>y \<in> S. (y, z) \<in> r\<rbrakk> \<Longrightarrow> (L, z) \<in> r"
  by (simp add: isLub_def A_def r_def)

lemma isLubI:
  "\<lbrakk>L \<in> A; \<forall>y \<in> S. (y, L) \<in> r; (\<forall>z \<in> A. (\<forall>y \<in> S. (y, z)\<in>r) \<longrightarrow> (L, z) \<in> r)\<rbrakk> \<Longrightarrow> isLub S cl L"
  by (simp add: isLub_def A_def r_def)

end

subsection \<open>glb\<close>

context CL
begin

lemma glb_in_lattice: "S \<subseteq> A \<Longrightarrow> glb S cl \<in> A"
  by (metis A_def CL.lub_in_lattice dualA_iff glb_dual_lub local.dual)

lemma glb_lower: "\<lbrakk>S \<subseteq> A; x \<in> S\<rbrakk> \<Longrightarrow> (glb S cl, x) \<in> r"
  by (metis A_def CL.lub_upper dualA_iff dualr_iff glb_dual_lub local.dual r_def)

end

text \<open>
  Reduce the sublattice property by using substructural properties;
  abandoned see \<open>Tarski_4.ML\<close>.
\<close>

context CLF
begin

declare f_cl [simp]

lemma f_in_funcset: "f \<in> A \<rightarrow> A"
  by (simp add: A_def)

lemma monotone_f: "monotone f A r"
  by (simp add: A_def r_def)

lemma CLF_dual: "(dual cl, f) \<in> CLF_set"
proof -
  have "Tarski.monotone f A (order (dual cl))"
    by (metis (no_types) A_def PO.monotone_dual PO_axioms dualA_iff monotone_f r_def)
  then show ?thesis
    by (simp add: A_def CLF_set_def CL_dualCL)
qed

lemma dual: "CLF (dual cl) f"
  by (rule CLF.intro) (rule CLF_dual)

end

subsection \<open>fixed points\<close>

lemma fix_subset: "fix f A \<subseteq> A"
  by (auto simp: fix_def)

lemma fix_imp_eq: "x \<in> fix f A \<Longrightarrow> f x = x"
  by (simp add: fix_def)

lemma fixf_subset: "\<lbrakk>A \<subseteq> B; x \<in> fix (\<lambda>y \<in> A. f y) A\<rbrakk> \<Longrightarrow> x \<in> fix f B"
  by (auto simp: fix_def)

subsection \<open>lemmas for Tarski, lub\<close>

context CLF
begin

lemma lubH_le_flubH:
  assumes "H = {x \<in> A. (x, f x) \<in> r}"
  shows "(lub H cl, f (lub H cl)) \<in> r"
proof (intro lub_least ballI)
  show "H \<subseteq> A"
    using assms
    by auto
  show "f (lub H cl) \<in> A"
    using \<open>H \<subseteq> A\<close> f_in_funcset lub_in_lattice by auto
  show "(x, f (lub H cl)) \<in> r" if "x \<in> H" for x
  proof -
    have "(f x, f (lub H cl)) \<in> r"
      by (meson \<open>H \<subseteq> A\<close> in_mono lub_in_lattice lub_upper monotoneE monotone_f that)
    moreover have "(x, f x) \<in> r"
      using assms that by blast
    ultimately show ?thesis
      using po.transE by blast
  qed
qed

lemma lubH_is_fixp:
  assumes "H = {x \<in> A. (x, f x) \<in> r}"
  shows "lub H cl \<in> fix f A"
proof -
  have "(f (lub H cl), lub H cl) \<in> r"
  proof -
    have "(lub H cl, f (lub H cl)) \<in> r"
      using assms lubH_le_flubH by blast
    then have "(f (lub H cl), f (f (lub H cl))) \<in> r"
      by (meson PO_imp_refl_on monotoneE monotone_f refl_on_domain)
    then have "f (lub H cl) \<in> H"
      by (metis (no_types, lifting) PO_imp_refl_on assms mem_Collect_eq refl_on_domain)
    then show ?thesis
      by (simp add: assms lub_upper)
  qed
  with assms show ?thesis
    by (simp add: fix_def antisymE lubH_le_flubH lub_in_lattice)
qed

lemma fixf_le_lubH:
  assumes "H = {x \<in> A. (x, f x) \<in> r}" "x \<in> fix f A"
  shows "(x, lub H cl) \<in> r"
proof -
  have "x \<in> P \<Longrightarrow> x \<in> H"
    by (simp add: assms P_def fix_imp_eq [of _ f A] reflE fix_subset [of f A, THEN subsetD])
  with assms show ?thesis
    by (metis (no_types, lifting) P_def lub_upper mem_Collect_eq subset_eq)
qed

subsection \<open>Tarski fixpoint theorem 1, first part\<close>

lemma T_thm_1_lub: "lub P cl = lub {x \<in> A. (x, f x) \<in> r} cl"
proof -
  have "lub {x \<in> A. (x, f x) \<in> r} cl = lub (fix f A) cl"
  proof (rule antisymE)
    show "(lub {x \<in> A. (x, f x) \<in> r} cl, lub (fix f A) cl) \<in> r"
      by (simp add: fix_subset lubH_is_fixp lub_upper)
    have "\<And>a. a \<in> fix f A \<Longrightarrow> a \<in> A"
      by (meson fix_subset subset_iff)
    then show "(lub (fix f A) cl, lub {x \<in> A. (x, f x) \<in> r} cl) \<in> r"
      by (simp add: fix_subset fixf_le_lubH lubH_is_fixp lub_least)
  qed
  then show ?thesis
    using P_def by auto
qed

lemma glbH_is_fixp:
  assumes "H = {x \<in> A. (f x, x) \<in> r}" shows "glb H cl \<in> P"
  \<comment> \<open>Tarski for glb\<close>
proof -
  have "glb H cl \<in> fix f (pset (dual cl))"
    using assms CLF.lubH_is_fixp [OF dual] PO.dualr_iff PO_axioms
    by (fastforce simp add: A_def r_def glb_dual_lub)
  then show ?thesis
    by (simp add: A_def P_def)
qed

lemma T_thm_1_glb: "glb P cl = glb {x \<in> A. (f x, x) \<in> r} cl"
  unfolding glb_dual_lub P_def A_def r_def
  using CLF.T_thm_1_lub dualA_iff dualr_iff local.dual by force

subsection \<open>interval\<close>

lemma rel_imp_elem: "(x, y) \<in> r \<Longrightarrow> x \<in> A"
  using CO_refl_on by (auto simp: refl_on_def)

lemma interval_subset: "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> interval r a b \<subseteq> A"
  by (simp add: interval_def) (blast intro: rel_imp_elem)

lemma intervalI: "\<lbrakk>(a, x) \<in> r; (x, b) \<in> r\<rbrakk> \<Longrightarrow> x \<in> interval r a b"
  by (simp add: interval_def)

lemma interval_lemma1: "\<lbrakk>S \<subseteq> interval r a b; x \<in> S\<rbrakk> \<Longrightarrow> (a, x) \<in> r"
  unfolding interval_def by fast

lemma interval_lemma2: "\<lbrakk>S \<subseteq> interval r a b; x \<in> S\<rbrakk> \<Longrightarrow> (x, b) \<in> r"
  unfolding interval_def by fast

lemma a_less_lub: "\<lbrakk>S \<subseteq> A; S \<noteq> {}; \<forall>x \<in> S. (a,x) \<in> r; \<forall>y \<in> S. (y, L) \<in> r\<rbrakk> \<Longrightarrow> (a, L) \<in> r"
  by (blast intro: transE)

lemma S_intv_cl: "\<lbrakk>a \<in> A; b \<in> A; S \<subseteq> interval r a b\<rbrakk> \<Longrightarrow> S \<subseteq> A"
  by (simp add: subset_trans [OF _ interval_subset])

lemma L_in_interval:
  assumes "b \<in> A" and S: "S \<subseteq> interval r a b" "isLub S cl L" "S \<noteq> {}"
  shows "L \<in> interval r a b"
proof (rule intervalI)
  show "(a, L) \<in> r"
    by (meson PO_imp_trans all_not_in_conv S interval_lemma1 isLub_upper transD)
  show "(L, b) \<in> r"
    using \<open>b \<in> A\<close> assms interval_lemma2 isLub_least by auto
qed

lemma G_in_interval:
  assumes "b \<in> A" and S: "S \<subseteq> interval r a b" "isGlb S cl G" "S \<noteq> {}"
  shows "G \<in> interval r a b"
proof -
  have "a \<in> A"
    using S(1) \<open>S \<noteq> {}\<close> interval_lemma1 rel_imp_elem by blast
  with assms show ?thesis
    by (metis (no_types) A_def CLF.L_in_interval dualA_iff interval_dual isGlb_dual_isLub local.dual)
qed

lemma intervalPO:
  "\<lbrakk>a \<in> A; b \<in> A; interval r a b \<noteq> {}\<rbrakk>
    \<Longrightarrow> \<lparr>pset = interval r a b, order = induced (interval r a b) r\<rparr> \<in> PartialOrder"
  by (rule po_subset_po) (simp add: interval_subset)

lemma intv_CL_lub:
  assumes "a \<in> A" "b \<in> A" "interval r a b \<noteq> {}" and S: "S \<subseteq> interval r a b"
  shows "\<exists>L. isLub S \<lparr>pset = interval r a b, order = induced (interval r a b) r\<rparr>  L"
proof -
  obtain L where L: "isLub S cl L"
    by (meson CL_imp_ex_isLub S_intv_cl assms(1) assms(2) assms(4))
  show ?thesis
    unfolding isLub_def potype.simps
    proof (intro exI impI conjI ballI)
    let ?L = "(if S = {} then a else L)"
    show Lin: "?L \<in> interval r a b"
      using L L_in_interval assms left_in_interval by auto
    show "(y, ?L) \<in> induced (interval r a b) r" if "y \<in> S" for y
    proof -
      have "S \<noteq> {}"
        using that by blast
      then show ?thesis
        using L Lin S indI isLub_upper that by auto
    qed
  show "(?L, z) \<in> induced (interval r a b) r"
    if "z \<in> interval r a b" and "\<forall>y\<in>S. (y, z) \<in> induced (interval r a b) r" for z
      using that L
      apply (simp add: isLub_def induced_def interval_imp_mem)
      by (metis (full_types) A_def Lin \<open>a \<in> A\<close> \<open>b \<in> A\<close> interval_subset r_def subset_eq)
  qed
qed

lemmas intv_CL_glb = intv_CL_lub [THEN Rdual]

lemma interval_is_sublattice: "\<lbrakk>a \<in> A; b \<in> A; interval r a b \<noteq> {}\<rbrakk> \<Longrightarrow> interval r a b <<= cl"
  apply (rule sublatticeI)
   apply (simp add: interval_subset)
  by (simp add: CompleteLatticeI intervalPO intv_CL_glb intv_CL_lub)

lemmas interv_is_compl_latt = interval_is_sublattice [THEN sublattice_imp_CL]

subsection \<open>Top and Bottom\<close>

lemma Top_dual_Bot: "Top cl = Bot (dual cl)"
  by (simp add: Top_def Bot_def least_def greatest_def)

lemma Bot_dual_Top: "Bot cl = Top (dual cl)"
  by (simp add: Top_def Bot_def least_def greatest_def)

lemma Bot_in_lattice: "Bot cl \<in> A"
  unfolding Bot_def least_def
  apply (rule_tac a = "glb A cl" in someI2)
  using glb_in_lattice glb_lower by (auto simp: A_def r_def)

lemma Top_in_lattice: "Top cl \<in> A"
  using A_def CLF.Bot_in_lattice Top_dual_Bot local.dual by force

lemma Top_prop: "x \<in> A \<Longrightarrow> (x, Top cl) \<in> r"
  unfolding Top_def greatest_def
  apply (rule_tac a = "lub A cl" in someI2)
  using lub_in_lattice lub_upper by (auto simp: A_def r_def)

lemma Bot_prop: "x \<in> A \<Longrightarrow> (Bot cl, x) \<in> r"
  using A_def Bot_dual_Top CLF.Top_prop dualA_iff dualr_iff local.dual r_def by fastforce

lemma Top_intv_not_empty: "x \<in> A \<Longrightarrow> interval r x (Top cl) \<noteq> {}"
  using Top_prop intervalI reflE by force

lemma Bot_intv_not_empty: "x \<in> A \<Longrightarrow> interval r (Bot cl) x \<noteq> {}"
  using Bot_dual_Top Bot_prop intervalI reflE by fastforce

text \<open>the set of fixed points form a partial order\<close>
proposition fixf_po: "\<lparr>pset = P, order = induced P r\<rparr> \<in> PartialOrder"
  by (simp add: P_def fix_subset po_subset_po)

end

context Tarski
begin

lemma Y_subset_A: "Y \<subseteq> A"
  by (rule subset_trans [OF _ fix_subset]) (rule Y_ss [simplified P_def])

lemma lubY_in_A: "lub Y cl \<in> A"
  by (rule Y_subset_A [THEN lub_in_lattice])

lemma lubY_le_flubY: "(lub Y cl, f (lub Y cl)) \<in> r"
proof (intro lub_least Y_subset_A ballI)
  show "f (lub Y cl) \<in> A"
    by (meson Tarski.monotone_def lubY_in_A monotone_f reflE rel_imp_elem)
  show "(x, f (lub Y cl)) \<in> r" if "x \<in> Y" for x
  proof
    have "\<And>A. Y \<subseteq> A \<Longrightarrow> x \<in> A"
      using that by blast
    moreover have "(x, lub Y cl) \<in> r"
      using that by (simp add: Y_subset_A lub_upper)
    ultimately show "(x, f (lub Y cl)) \<in> r"
      by (metis (no_types) Tarski.Y_ss Tarski_axioms Y_subset_A fix_imp_eq lubY_in_A monotoneE monotone_f)
  qed auto
qed

lemma intY1_subset: "intY1 \<subseteq> A"
  unfolding intY1_def using Top_in_lattice interval_subset lubY_in_A by auto

lemmas intY1_elem = intY1_subset [THEN subsetD]

lemma intY1_f_closed:
  assumes "x \<in> intY1" shows "f x \<in> intY1"
proof (simp add: intY1_def interval_def, rule conjI)
  show "(lub Y cl, f x) \<in> r"
    using assms intY1_elem interval_imp_mem lubY_in_A unfolding intY1_def
    using lubY_le_flubY monotoneE monotone_f po.transE by blast
  then show "(f x, Top cl) \<in> r"
    by (meson PO_imp_refl_on Top_prop refl_onD2)
qed

lemma intY1_mono: "monotone (\<lambda> x \<in> intY1. f x) intY1 (induced intY1 r)"
  apply (auto simp add: monotone_def induced_def intY1_f_closed)
  apply (blast intro: intY1_elem monotone_f [THEN monotoneE])
  done

lemma intY1_is_cl: "\<lparr>pset = intY1, order = induced intY1 r\<rparr> \<in> CompleteLattice"
  unfolding intY1_def
  by (simp add: Top_in_lattice Top_intv_not_empty interv_is_compl_latt lubY_in_A)

lemma v_in_P: "v \<in> P"
proof -
  have "v \<in> fix (restrict f intY1) intY1"
    unfolding v_def
    apply (rule CLF.glbH_is_fixp
        [OF CLF.intro, unfolded CLF_set_def, of "\<lparr>pset = intY1, order = induced intY1 r\<rparr>", simplified])
    using intY1_f_closed intY1_is_cl intY1_mono apply blast+
    done
  then show ?thesis
    unfolding P_def
  by (meson fixf_subset intY1_subset)
qed

lemma z_in_interval: "\<lbrakk>z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r\<rbrakk> \<Longrightarrow> z \<in> intY1"
  unfolding intY1_def P_def
  by (meson Top_prop Y_subset_A fix_subset in_mono indE intervalI lub_least)

lemma tarski_full_lemma: "\<exists>L. isLub Y \<lparr>pset = P, order = induced P r\<rparr> L"
proof
  have "(y, v) \<in> induced P r" if "y \<in> Y" for y
  proof -
    have "(y, lub Y cl) \<in> r"
      by (simp add: Y_subset_A lub_upper that)
    moreover have "(lub Y cl, v) \<in> r"
      by (metis (no_types, lifting) CL.glb_in_lattice CL.intro intY1_def intY1_is_cl interval_imp_mem lub_dual_glb mem_Collect_eq select_convs(1) subsetI v_def)
    ultimately have "(y, v) \<in> r"
      using po.transE by blast
    then show ?thesis
      using Y_ss indI that v_in_P by auto
  qed
  moreover have "(v, z) \<in> induced P r" if "z \<in> P" "\<forall>y\<in>Y. (y, z) \<in> induced P r" for z
  proof (rule indI)
    have "((\<lambda>x \<in> intY1. f x) z, z) \<in> induced intY1 r"
      by (metis P_def fix_imp_eq in_mono indI intY1_subset reflE restrict_apply' that z_in_interval)
    then show "(v, z) \<in> r"
      by (metis (no_types, lifting) CL.glb_lower CL_def indE intY1_is_cl intY1_subset mem_Collect_eq select_convs(1,2) subsetI that v_def z_in_interval)
  qed (auto simp: that v_in_P)
  ultimately
  show "isLub Y \<lparr>pset = P, order = induced P r\<rparr> v"
    by (simp add: isLub_def v_in_P)
qed

end

lemma CompleteLatticeI_simp:
  "\<lbrakk>po \<in> PartialOrder; \<And>S. S \<subseteq> A \<Longrightarrow> \<exists>L. isLub S po  L; A = pset po\<rbrakk> \<Longrightarrow> po \<in> CompleteLattice"
  by (metis CompleteLatticeI Rdual)

theorem (in CLF) Tarski_full: "\<lparr>pset = P, order = induced P r\<rparr> \<in> CompleteLattice"
proof (intro CompleteLatticeI_simp allI impI)
  show "\<lparr>pset = P, order = induced P r\<rparr> \<in> PartialOrder"
    by (simp add: fixf_po)
  show "\<And>S. S \<subseteq> P \<Longrightarrow> \<exists>L. isLub S \<lparr>pset = P, order = induced P r\<rparr> L"
    unfolding P_def A_def r_def
  proof (rule Tarski.tarski_full_lemma [OF Tarski.intro [OF _ Tarski_axioms.intro]])
    show "CLF cl f" ..
  qed
qed auto

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Big sum and product over function bodies\<close>

theory Groups_Big_Fun
imports
  MainRLT
begin

subsection \<open>Abstract product\<close>

locale comm_monoid_fun = comm_monoid
begin

definition G :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a"
where
  expand_set: "G g = comm_monoid_set.F f \<^bold>1 g {a. g a \<noteq> \<^bold>1}"

interpretation F: comm_monoid_set f "\<^bold>1"
  ..

lemma expand_superset:
  assumes "finite A" and "{a. g a \<noteq> \<^bold>1} \<subseteq> A"
  shows "G g = F.F g A"
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply (simp_all add: assms)
  done

lemma conditionalize:
  assumes "finite A"
  shows "F.F g A = G (\<lambda>a. if a \<in> A then g a else \<^bold>1)"
  using assms
  apply (simp add: expand_set)
  apply (rule F.same_carrierI [of A])
  apply auto
  done

lemma neutral [simp]:
  "G (\<lambda>a. \<^bold>1) = \<^bold>1"
  by (simp add: expand_set)

lemma update [simp]:
  assumes "finite {a. g a \<noteq> \<^bold>1}"
  assumes "g a = \<^bold>1"
  shows "G (g(a := b)) = b \<^bold>* G g"
proof (cases "b = \<^bold>1")
  case True with \<open>g a = \<^bold>1\<close> show ?thesis
    by (simp add: expand_set) (rule F.cong, auto)
next
  case False
  moreover have "{a'. a' \<noteq> a \<longrightarrow> g a' \<noteq> \<^bold>1} = insert a {a. g a \<noteq> \<^bold>1}"
    by auto
  moreover from \<open>g a = \<^bold>1\<close> have "a \<notin> {a. g a \<noteq> \<^bold>1}"
    by simp
  moreover have "F.F (\<lambda>a'. if a' = a then b else g a') {a. g a \<noteq> \<^bold>1} = F.F g {a. g a \<noteq> \<^bold>1}"
    by (rule F.cong) (auto simp add: \<open>g a = \<^bold>1\<close>)
  ultimately show ?thesis using \<open>finite {a. g a \<noteq> \<^bold>1}\<close> by (simp add: expand_set)
qed

lemma infinite [simp]:
  "\<not> finite {a. g a \<noteq> \<^bold>1} \<Longrightarrow> G g = \<^bold>1"
  by (simp add: expand_set)

lemma cong [cong]:
  assumes "\<And>a. g a = h a"
  shows "G g = G h"
  using assms by (simp add: expand_set)

lemma not_neutral_obtains_not_neutral:
  assumes "G g \<noteq> \<^bold>1"
  obtains a where "g a \<noteq> \<^bold>1"
  using assms by (auto elim: F.not_neutral_contains_not_neutral simp add: expand_set)

lemma reindex_cong:
  assumes "bij l"
  assumes "g \<circ> l = h"
  shows "G g = G h"
proof -
  from assms have unfold: "h = g \<circ> l" by simp
  from \<open>bij l\<close> have "inj l" by (rule bij_is_inj)
  then have "inj_on l {a. h a \<noteq> \<^bold>1}" by (rule subset_inj_on) simp
  moreover from \<open>bij l\<close> have "{a. g a \<noteq> \<^bold>1} = l ` {a. h a \<noteq> \<^bold>1}"
    by (auto simp add: image_Collect unfold elim: bij_pointE)
  moreover have "\<And>x. x \<in> {a. h a \<noteq> \<^bold>1} \<Longrightarrow> g (l x) = h x"
    by (simp add: unfold)
  ultimately have "F.F g {a. g a \<noteq> \<^bold>1} = F.F h {a. h a \<noteq> \<^bold>1}"
    by (rule F.reindex_cong)
  then show ?thesis by (simp add: expand_set)
qed

lemma distrib:
  assumes "finite {a. g a \<noteq> \<^bold>1}" and "finite {a. h a \<noteq> \<^bold>1}"
  shows "G (\<lambda>a. g a \<^bold>* h a) = G g \<^bold>* G h"
proof -
  from assms have "finite ({a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1})" by simp
  moreover have "{a. g a \<^bold>* h a \<noteq> \<^bold>1} \<subseteq> {a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1}"
    by auto (drule sym, simp)
  ultimately show ?thesis
    using assms
    by (simp add: expand_superset [of "{a. g a \<noteq> \<^bold>1} \<union> {a. h a \<noteq> \<^bold>1}"] F.distrib)
qed

lemma swap:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>b. G (\<lambda>a. g a b))"
proof -
  from \<open>finite C\<close> subset
    have "finite ({a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1})"
    by (rule rev_finite_subset)
  then have fins:
    "finite {b. \<exists>a. g a b \<noteq> \<^bold>1}" "finite {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    by (auto simp add: finite_cartesian_product_iff)
  have subsets: "\<And>a. {b. g a b \<noteq> \<^bold>1} \<subseteq> {b. \<exists>a. g a b \<noteq> \<^bold>1}"
    "\<And>b. {a. g a b \<noteq> \<^bold>1} \<subseteq> {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    "{a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1} \<noteq> \<^bold>1} \<subseteq> {a. \<exists>b. g a b \<noteq> \<^bold>1}"
    "{a. F.F (\<lambda>aa. g aa a) {a. \<exists>b. g a b \<noteq> \<^bold>1} \<noteq> \<^bold>1} \<subseteq> {b. \<exists>a. g a b \<noteq> \<^bold>1}"
    by (auto elim: F.not_neutral_contains_not_neutral)
  from F.swap have
    "F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) {a. \<exists>b. g a b \<noteq> \<^bold>1} =
      F.F (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> \<^bold>1}) {b. \<exists>a. g a b \<noteq> \<^bold>1}" .
  with subsets fins have "G (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) =
    G (\<lambda>b. F.F (\<lambda>a. g a b) {a. \<exists>b. g a b \<noteq> \<^bold>1})"
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> \<^bold>1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> \<^bold>1}"])
  with subsets fins show ?thesis
    by (auto simp add: expand_superset [of "{b. \<exists>a. g a b \<noteq> \<^bold>1}"]
      expand_superset [of "{a. \<exists>b. g a b \<noteq> \<^bold>1}"])
qed

lemma cartesian_product:
  assumes "finite C"
  assumes subset: "{a. \<exists>b. g a b \<noteq> \<^bold>1} \<times> {b. \<exists>a. g a b \<noteq> \<^bold>1} \<subseteq> C" (is "?A \<times> ?B \<subseteq> C")
  shows "G (\<lambda>a. G (g a)) = G (\<lambda>(a, b). g a b)"
proof -
  from subset \<open>finite C\<close> have fin_prod: "finite (?A \<times> ?B)"
    by (rule finite_subset)
  from fin_prod have "finite ?A" and "finite ?B"
    by (auto simp add: finite_cartesian_product_iff)
  have *: "G (\<lambda>a. G (g a)) =
    (F.F (\<lambda>a. F.F (g a) {b. \<exists>a. g a b \<noteq> \<^bold>1}) {a. \<exists>b. g a b \<noteq> \<^bold>1})"
    apply (subst expand_superset [of "?B"])
    apply (rule \<open>finite ?B\<close>)
    apply auto
    apply (subst expand_superset [of "?A"])
    apply (rule \<open>finite ?A\<close>)
    apply auto
    apply (erule F.not_neutral_contains_not_neutral)
    apply auto
    done
  have "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> \<^bold>1} \<subseteq> ?A \<times> ?B"
    by auto
  with subset have **: "{p. (case p of (a, b) \<Rightarrow> g a b) \<noteq> \<^bold>1} \<subseteq> C"
    by blast
  show ?thesis
    apply (simp add: *)
    apply (simp add: F.cartesian_product)
    apply (subst expand_superset [of C])
    apply (rule \<open>finite C\<close>)
    apply (simp_all add: **)
    apply (rule F.same_carrierI [of C])
    apply (rule \<open>finite C\<close>)
    apply (simp_all add: subset)
    apply auto
    done
qed

lemma cartesian_product2:
  assumes fin: "finite D"
  assumes subset: "{(a, b). \<exists>c. g a b c \<noteq> \<^bold>1} \<times> {c. \<exists>a b. g a b c \<noteq> \<^bold>1} \<subseteq> D" (is "?AB \<times> ?C \<subseteq> D")
  shows "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>(a, b, c). g a b c)"
proof -
  have bij: "bij (\<lambda>(a, b, c). ((a, b), c))"
    by (auto intro!: bijI injI simp add: image_def)
  have "{p. \<exists>c. g (fst p) (snd p) c \<noteq> \<^bold>1} \<times> {c. \<exists>p. g (fst p) (snd p) c \<noteq> \<^bold>1} \<subseteq> D"
    by auto (insert subset, blast)
  with fin have "G (\<lambda>p. G (g (fst p) (snd p))) = G (\<lambda>(p, c). g (fst p) (snd p) c)"
    by (rule cartesian_product)
  then have "G (\<lambda>(a, b). G (g a b)) = G (\<lambda>((a, b), c). g a b c)"
    by (auto simp add: split_def)
  also have "G (\<lambda>((a, b), c). g a b c) = G (\<lambda>(a, b, c). g a b c)"
    using bij by (rule reindex_cong [of "\<lambda>(a, b, c). ((a, b), c)"]) (simp add: fun_eq_iff)
  finally show ?thesis .
qed

lemma delta [simp]:
  "G (\<lambda>b. if b = a then g b else \<^bold>1) = g a"
proof -
  have "{b. (if b = a then g b else \<^bold>1) \<noteq> \<^bold>1} \<subseteq> {a}" by auto
  then show ?thesis by (simp add: expand_superset [of "{a}"])
qed

lemma delta' [simp]:
  "G (\<lambda>b. if a = b then g b else \<^bold>1) = g a"
proof -
  have "(\<lambda>b. if a = b then g b else \<^bold>1) = (\<lambda>b. if b = a then g b else \<^bold>1)"
    by (simp add: fun_eq_iff)
  then have "G (\<lambda>b. if a = b then g b else \<^bold>1) = G (\<lambda>b. if b = a then g b else \<^bold>1)"
    by (simp cong del: cong)
  then show ?thesis by simp
qed

end

subsection \<open>Concrete sum\<close>

context comm_monoid_add
begin

sublocale Sum_any: comm_monoid_fun plus 0
  rewrites "comm_monoid_set.F plus 0 = sum"
  defines Sum_any = Sum_any.G
proof -
  show "comm_monoid_fun plus 0" ..
  then interpret Sum_any: comm_monoid_fun plus 0 .
  from sum_def show "comm_monoid_set.F plus 0 = sum" by (auto intro: sym)
qed

end

syntax (ASCII)
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3SUM _. _)" [0, 10] 10)
syntax
  "_Sum_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"    ("(3\<Sum>_. _)" [0, 10] 10)
translations
  "\<Sum>a. b" \<rightleftharpoons> "CONST Sum_any (\<lambda>a. b)"

lemma Sum_any_left_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "Sum_any g * r = (\<Sum>n. g n * r)"
proof -
  note assms
  moreover have "{a. g a * r \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: sum_distrib_right Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_right_distrib:
  fixes r :: "'a :: semiring_0"
  assumes "finite {a. g a \<noteq> 0}"
  shows "r * Sum_any g = (\<Sum>n. r * g n)"
proof -
  note assms
  moreover have "{a. r * g a \<noteq> 0} \<subseteq> {a. g a \<noteq> 0}" by auto
  ultimately show ?thesis
    by (simp add: sum_distrib_left Sum_any.expand_superset [of "{a. g a \<noteq> 0}"])
qed

lemma Sum_any_product:
  fixes f g :: "'b \<Rightarrow> 'a::semiring_0"
  assumes "finite {a. f a \<noteq> 0}" and "finite {b. g b \<noteq> 0}"
  shows "Sum_any f * Sum_any g = (\<Sum>a. \<Sum>b. f a * g b)"
proof -
  have subset_f: "{a. (\<Sum>b. f a * g b) \<noteq> 0} \<subseteq> {a. f a \<noteq> 0}"
    by rule (simp, rule, auto)
  moreover have subset_g: "\<And>a. {b. f a * g b \<noteq> 0} \<subseteq> {b. g b \<noteq> 0}"
    by rule (simp, rule, auto)
  ultimately show ?thesis using assms
    by (auto simp add: Sum_any.expand_set [of f] Sum_any.expand_set [of g]
      Sum_any.expand_superset [of "{a. f a \<noteq> 0}"] Sum_any.expand_superset [of "{b. g b \<noteq> 0}"]
      sum_product)
qed

lemma Sum_any_eq_zero_iff [simp]:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "finite {a. f a \<noteq> 0}"
  shows "Sum_any f = 0 \<longleftrightarrow> f = (\<lambda>_. 0)"
  using assms by (simp add: Sum_any.expand_set fun_eq_iff)

subsection \<open>Concrete product\<close>

context comm_monoid_mult
begin

sublocale Prod_any: comm_monoid_fun times 1
  rewrites "comm_monoid_set.F times 1 = prod"
  defines Prod_any = Prod_any.G
proof -
  show "comm_monoid_fun times 1" ..
  then interpret Prod_any: comm_monoid_fun times 1 .
  from prod_def show "comm_monoid_set.F times 1 = prod" by (auto intro: sym)
qed

end

syntax (ASCII)
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3PROD _. _)" [0, 10] 10)
syntax
  "_Prod_any" :: "pttrn \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3\<Prod>_. _)" [0, 10] 10)
translations
  "\<Prod>a. b" == "CONST Prod_any (\<lambda>a. b)"

lemma Prod_any_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "f a = 0"
  shows "(\<Prod>a. f a) = 0"
proof -
  from \<open>f a = 0\<close> have "f a \<noteq> 1" by simp
  with \<open>f a = 0\<close> have "\<exists>a. f a \<noteq> 1 \<and> f a = 0" by blast
  with \<open>finite {a. f a \<noteq> 1}\<close> show ?thesis
    by (simp add: Prod_any.expand_set prod_zero)
qed

lemma Prod_any_not_zero:
  fixes f :: "'b \<Rightarrow> 'a :: comm_semiring_1"
  assumes "finite {a. f a \<noteq> 1}"
  assumes "(\<Prod>a. f a) \<noteq> 0"
  shows "f a \<noteq> 0"
  using assms Prod_any_zero [of f] by blast

lemma power_Sum_any:
  assumes "finite {a. f a \<noteq> 0}"
  shows "c ^ (\<Sum>a. f a) = (\<Prod>a. c ^ f a)"
proof -
  have "{a. c ^ f a \<noteq> 1} \<subseteq> {a. f a \<noteq> 0}"
    by (auto intro: ccontr)
  with assms show ?thesis
    by (simp add: Sum_any.expand_set Prod_any.expand_superset power_sum)
qed

end


section "Common"

theory Common
  imports
  "HOL-Library.Going_To_Filter"
  "Akra_Bazzi.Akra_Bazzi_Method"
  "Akra_Bazzi.Akra_Bazzi_Approximation"
  "HOL-Library.Code_Target_Numeral"
  "Time_Monad"
begin

type_synonym point = "int * int"

subsection "Auxiliary Functions and Lemmas"

subsubsection "Landau Auxiliary"

text \<open>
  The following lemma expresses a procedure for deriving complexity properties of
  the form @{prop"t \<in> O[m going_to at_top within A](f o m)"} where
    \<^item> \<open>t\<close> is a (timing) function on same data domain (e.g. lists),
    \<^item> \<open>m\<close> is a measure function on that data domain (e.g. length),
    \<^item> \<open>t'\<close> is a function on @{typ nat},
    \<^item> \<open>A\<close> is the set of valid inputs for the data domain.
  One needs to show that
    \<^item> \<open>t\<close> is bounded by @{term "t' o m"} for valid inputs
    \<^item> @{prop"t' \<in> O(f)"}
  to conclude the overall property @{prop"t \<in> O[m going_to at_top within A](f o m)"}.
\<close>

lemma const_1_bigo_n_ln_n:
  "(\<lambda>(n::nat). 1) \<in> O(\<lambda>n. n * ln n)"
proof -
  have "\<exists>N. \<forall>(n::nat) \<ge> N. (\<lambda>x. 1 \<le> x * ln x) n"
  proof -
    have "\<forall>(n::nat) \<ge> 3. (\<lambda>x. 1 \<le> x * ln x) n"
    proof standard
      fix n
      show "3 \<le> n \<longrightarrow> 1 \<le> real n * ln (real n)"
      proof standard
        assume "3 \<le> n"
        hence "1 \<le> ln (real n)" "1 \<le> real n"
          using ln3_gt_1 ln_ln_nonneg' by auto
        thus "1 \<le> real n * ln (real n)"
          by (auto simp: order_trans)
      qed
    qed
    thus ?thesis
      by blast
  qed
  thus ?thesis
    by auto
qed

subsubsection "Miscellaneous Lemmas"

lemma set_take_drop_i_le_j:
  "i \<le> j \<Longrightarrow> set xs = set (take j xs) \<union> set (drop i xs)"
proof (induction xs arbitrary: i j)
  case (Cons x xs)
  show ?case
  proof (cases "i = 0")
    case True
    thus ?thesis
      using set_take_subset by force
  next
    case False
    hence "set xs = set (take (j - 1) xs) \<union> set (drop (i - 1) xs)"
      by (simp add: Cons diff_le_mono)
    moreover have "set (take j (x # xs)) = insert x (set (take (j - 1) xs))"
      using False Cons.prems by (auto simp: take_Cons')
    moreover have "set (drop i (x # xs)) = set (drop (i - 1) xs)"
      using False Cons.prems by (auto simp: drop_Cons')
    ultimately show ?thesis
      by auto
  qed
qed simp

lemma set_take_drop:
  "set xs = set (take n xs) \<union> set (drop n xs)"
  using set_take_drop_i_le_j by fast

lemma
  assumes "sorted_wrt f xs"
  shows sorted_wrt_take: "sorted_wrt f (take n xs)"
  and sorted_wrt_drop: "sorted_wrt f (drop n xs)"
proof -
  from assms have "sorted_wrt f (take n xs @ drop n xs)" by simp
  then show "sorted_wrt f (take n xs)" and "sorted_wrt f (drop n xs)"
    unfolding sorted_wrt_append by simp_all
qed

lemma sorted_wrt_filter:
  "sorted_wrt f xs \<Longrightarrow> sorted_wrt f (filter P xs)"
  by (induction xs) auto

lemma sorted_wrt_take_drop:
  "sorted_wrt f xs \<Longrightarrow> \<forall>x \<in> set (take n xs). \<forall>y \<in> set (drop n xs). f x y"
  using sorted_wrt_append[of f "take n xs" "drop n xs"] by simp

lemma sorted_wrt_hd_less:
  assumes "sorted_wrt f xs" "\<And>x. f x x"
  shows "\<forall>x \<in> set xs. f (hd xs) x"
  using assms by (cases xs) auto

lemma sorted_wrt_hd_less_take:
  assumes "sorted_wrt f (x # xs)" "\<And>x. f x x"
  shows "\<forall>y \<in> set (take n (x # xs)). f x y"
  using assms sorted_wrt_hd_less in_set_takeD by fastforce

lemma sorted_wrt_take_less_hd_drop:
  assumes "sorted_wrt f xs" "n < length xs"
  shows "\<forall>x \<in> set (take n xs). f x (hd (drop n xs))"
  using sorted_wrt_take_drop assms by fastforce

lemma sorted_wrt_hd_drop_less_drop:
  assumes "sorted_wrt f xs" "\<And>x. f x x"
  shows "\<forall>x \<in> set (drop n xs). f (hd (drop n xs)) x"
  using assms sorted_wrt_drop sorted_wrt_hd_less by blast

lemma length_filter_P_impl_Q:
   "(\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> length (filter P xs) \<le> length (filter Q xs)"
  by (induction xs) auto

lemma filter_Un:
  "set xs = A \<union> B \<Longrightarrow> set (filter P xs) = { x \<in> A. P x } \<union> { x \<in> B. P x }"
  by (induction xs) (auto, metis UnI1 insert_iff, metis UnI2 insert_iff)

subsubsection \<open>@{const length}\<close>

fun length_tm :: "'a list \<Rightarrow> nat tm" where
  "length_tm [] =1 return 0"
| "length_tm (x # xs) =1
    do {
      l <- length_tm xs;
      return (1 + l)
    }"

lemma length_eq_val_length_tm:
  "val (length_tm xs) = length xs"
  by (induction xs) auto

lemma time_length_tm:
  "time (length_tm xs) = length xs + 1"
  by (induction xs) (auto simp: time_simps)

fun length_it' :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
  "length_it' acc [] = acc"
| "length_it' acc (x#xs) = length_it' (acc+1) xs"

definition length_it :: "'a list \<Rightarrow> nat" where
  "length_it xs = length_it' 0 xs"

lemma length_conv_length_it':
  "length xs + acc = length_it' acc xs"
  by (induction acc xs rule: length_it'.induct) auto

lemma length_conv_length_it[code_unfold]:
  "length xs = length_it xs"
  unfolding length_it_def using length_conv_length_it' add_0_right by metis

subsubsection \<open>@{const rev}\<close>

fun rev_it' :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "rev_it' acc [] = acc"
| "rev_it' acc (x#xs) = rev_it' (x#acc) xs"

definition rev_it :: "'a list \<Rightarrow> 'a list" where
  "rev_it xs = rev_it' [] xs"

lemma rev_conv_rev_it':
  "rev xs @ acc = rev_it' acc xs"
  by (induction acc xs rule: rev_it'.induct) auto

lemma rev_conv_rev_it[code_unfold]:
  "rev xs = rev_it xs"
  unfolding rev_it_def using rev_conv_rev_it' append_Nil2 by metis

subsubsection \<open>@{const take}\<close>

fun take_tm :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list tm" where
  "take_tm n [] =1 return []"
| "take_tm n (x # xs) =1
    (case n of
       0 \<Rightarrow> return []
     | Suc m \<Rightarrow> do {
         ys <- take_tm m xs;
         return (x # ys)
       }
    )"

lemma take_eq_val_take_tm:
  "val (take_tm n xs) = take n xs"
  by (induction xs arbitrary: n) (auto split: nat.split)

lemma time_take_tm:
  "time (take_tm n xs) = min n (length xs) + 1"
  by (induction xs arbitrary: n) (auto simp: time_simps split: nat.split)

subsubsection \<open>@{const filter}\<close>

fun filter_tm :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list tm" where
  "filter_tm P [] =1 return []"
| "filter_tm P (x # xs) =1
    (if P x then
       do {
         ys <- filter_tm P xs;
         return (x # ys)
       }
     else
       filter_tm P xs
    )"

lemma filter_eq_val_filter_tm:
  "val (filter_tm P xs) = filter P xs"
  by (induction xs) auto

lemma time_filter_tm:
  "time (filter_tm P xs) = length xs + 1"
  by (induction xs) (auto simp: time_simps)

fun filter_it' :: "'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "filter_it' acc P [] = rev acc"
| "filter_it' acc P (x#xs) = (
    if P x then
      filter_it' (x#acc) P xs
    else
      filter_it' acc P xs
  )"

definition filter_it :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "filter_it P xs = filter_it' [] P xs"

lemma filter_conv_filter_it':
  "rev acc @ filter P xs = filter_it' acc P xs"
  by (induction acc P xs rule: filter_it'.induct) auto

lemma filter_conv_filter_it[code_unfold]:
  "filter P xs = filter_it P xs"
  unfolding filter_it_def using filter_conv_filter_it' append_Nil rev.simps(1) by metis

subsubsection \<open>\<open>split_at\<close>\<close>

fun split_at_tm :: "nat \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list) tm" where
  "split_at_tm n [] =1 return ([], [])"
| "split_at_tm n (x # xs) =1 (
    case n of
      0 \<Rightarrow> return ([], x # xs)
    | Suc m \<Rightarrow>
      do {
        (xs', ys') <- split_at_tm m xs;
        return (x # xs', ys')
      }
  )"

fun split_at :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  "split_at n [] = ([], [])"
| "split_at n (x # xs) = (
    case n of
      0 \<Rightarrow> ([], x # xs)
    | Suc m \<Rightarrow>
        let (xs', ys') = split_at m xs in
        (x # xs', ys')
  )"

lemma split_at_eq_val_split_at_tm:
  "val (split_at_tm n xs) = split_at n xs"
  by (induction xs arbitrary: n) (auto split: nat.split prod.split)

lemma split_at_take_drop_conv:
  "split_at n xs = (take n xs, drop n xs)"
  by (induction xs arbitrary: n) (auto simp: split: nat.split)

lemma time_split_at_tm:
  "time (split_at_tm n xs) = min n (length xs) + 1"
  by (induction xs arbitrary: n) (auto simp: time_simps split: nat.split prod.split)

fun split_at_it' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a list)" where
  "split_at_it' acc n [] = (rev acc, [])"
| "split_at_it' acc n (x#xs) = (
    case n of
      0 \<Rightarrow> (rev acc, x#xs)
    | Suc m \<Rightarrow> split_at_it' (x#acc) m xs
  )"

definition split_at_it :: "nat \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a list)" where
  "split_at_it n xs = split_at_it' [] n xs"

lemma split_at_conv_split_at_it':
  assumes "(ts, ds) = split_at n xs" "(ts', ds') = split_at_it' acc n xs"
  shows "rev acc @ ts = ts'"
    and "ds = ds'"
  using assms
  by (induction acc n xs arbitrary: ts rule: split_at_it'.induct)
     (auto simp: split: prod.splits nat.splits)

lemma split_at_conv_split_at_it_prod:
  assumes "(ts, ds) = split_at n xs" "(ts', ds') = split_at_it n xs"
  shows "(ts, ds) = (ts', ds')"
  using assms unfolding split_at_it_def
  using split_at_conv_split_at_it' rev.simps(1) append_Nil by fast+

lemma split_at_conv_split_at_it[code_unfold]:
  "split_at n xs = split_at_it n xs"
  using split_at_conv_split_at_it_prod surj_pair by metis

declare split_at_tm.simps [simp del]
declare split_at.simps [simp del]

subsection "Mergesort"

subsubsection "Functional Correctness Proof"

definition sorted_fst :: "point list \<Rightarrow> bool" where
  "sorted_fst ps = sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1) ps"

definition sorted_snd :: "point list \<Rightarrow> bool" where
  "sorted_snd ps = sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. snd p\<^sub>0 \<le> snd p\<^sub>1) ps"

fun merge_tm :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list tm" where
  "merge_tm f (x # xs) (y # ys) =1 (
    if f x \<le> f y then
      do {
        tl <- merge_tm f xs (y # ys);
        return (x # tl)
      }
    else
      do {
        tl <- merge_tm f (x # xs) ys;
        return (y # tl)
      }
  )"
| "merge_tm f [] ys =1 return ys"
| "merge_tm f xs [] =1 return xs"

fun merge :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "merge f (x # xs) (y # ys) = (
    if f x \<le> f y then
      x # merge f xs (y # ys)
    else
      y # merge f (x # xs) ys
  )"
| "merge f [] ys = ys"
| "merge f xs [] = xs"

lemma merge_eq_val_merge_tm:
  "val (merge_tm f xs ys) = merge f xs ys"
  by (induction f xs ys rule: merge.induct) auto

lemma length_merge:
  "length (merge f xs ys) = length xs + length ys"
  by (induction f xs ys rule: merge.induct) auto

lemma set_merge:
  "set (merge f xs ys) = set xs \<union> set ys"
  by (induction f xs ys rule: merge.induct) auto

lemma distinct_merge:
  assumes "set xs \<inter> set ys = {}" "distinct xs" "distinct ys"
  shows "distinct (merge f xs ys)"
  using assms by (induction f xs ys rule: merge.induct) (auto simp: set_merge)

lemma sorted_merge:
  assumes "P = (\<lambda>x y. f x \<le> f y)"
  shows "sorted_wrt P (merge f xs ys) \<longleftrightarrow> sorted_wrt P xs \<and> sorted_wrt P ys"
  using assms by (induction f xs ys rule: merge.induct) (auto simp: set_merge)

declare split_at_take_drop_conv [simp]

function (sequential) mergesort_tm :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list tm" where
  "mergesort_tm f [] =1 return []"
| "mergesort_tm f [x] =1 return [x]"
| "mergesort_tm f xs =1 (
    do {
      n <- length_tm xs;
      (xs\<^sub>l, xs\<^sub>r) <- split_at_tm (n div 2) xs;
      l <- mergesort_tm f xs\<^sub>l;
      r <- mergesort_tm f xs\<^sub>r;
      merge_tm f l r
    }
  )"
  by pat_completeness auto
termination mergesort_tm
  by (relation "Wellfounded.measure (\<lambda>(_, xs). length xs)")
     (auto simp add: length_eq_val_length_tm split_at_eq_val_split_at_tm)

fun mergesort :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "mergesort f [] = []"
| "mergesort f [x] = [x]"
| "mergesort f xs = (
    let n = length xs div 2 in
    let (l, r) = split_at n xs in
    merge f (mergesort f l) (mergesort f r)
  )"

declare split_at_take_drop_conv [simp del]

lemma mergesort_eq_val_mergesort_tm:
  "val (mergesort_tm f xs) = mergesort f xs"
  by (induction f xs rule: mergesort.induct)
     (auto simp add: length_eq_val_length_tm split_at_eq_val_split_at_tm merge_eq_val_merge_tm split: prod.split)

lemma sorted_wrt_mergesort:
  "sorted_wrt (\<lambda>x y. f x \<le> f y) (mergesort f xs)"
  by (induction f xs rule: mergesort.induct) (auto simp: split_at_take_drop_conv sorted_merge)

lemma set_mergesort:
  "set (mergesort f xs) = set xs"
  by (induction f xs rule: mergesort.induct)
     (simp_all add: set_merge split_at_take_drop_conv, metis list.simps(15) set_take_drop)

lemma length_mergesort:
  "length (mergesort f xs) = length xs"
  by (induction f xs rule: mergesort.induct) (auto simp: length_merge split_at_take_drop_conv)

lemma distinct_mergesort:
  "distinct xs \<Longrightarrow> distinct (mergesort f xs)"
proof (induction f xs rule: mergesort.induct)
  case (3 f x y xs)
  let ?xs' = "x # y # xs"
  obtain l r where lr_def: "(l, r) = split_at (length ?xs' div 2) ?xs'"
    by (metis surj_pair)
  have "distinct l" "distinct r"
    using "3.prems" split_at_take_drop_conv distinct_take distinct_drop lr_def by (metis prod.sel)+
  hence "distinct (mergesort f l)" "distinct (mergesort f r)"
    using "3.IH" lr_def by auto
  moreover have "set l \<inter> set r = {}"
    using "3.prems" split_at_take_drop_conv lr_def by (metis append_take_drop_id distinct_append prod.sel)
  ultimately show ?case
    using lr_def by (auto simp: distinct_merge set_mergesort split: prod.splits)
qed auto

lemmas mergesort = sorted_wrt_mergesort set_mergesort length_mergesort distinct_mergesort

lemma sorted_fst_take_less_hd_drop:
  assumes "sorted_fst ps" "n < length ps"
  shows "\<forall>p \<in> set (take n ps). fst p \<le> fst (hd (drop n ps))"
  using assms sorted_wrt_take_less_hd_drop[of "\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1"] sorted_fst_def by fastforce

lemma sorted_fst_hd_drop_less_drop:
  assumes "sorted_fst ps"
  shows "\<forall>p \<in> set (drop n ps). fst (hd (drop n ps)) \<le> fst p"
  using assms sorted_wrt_hd_drop_less_drop[of "\<lambda>p\<^sub>0 p\<^sub>1. fst p\<^sub>0 \<le> fst p\<^sub>1"] sorted_fst_def by fastforce

subsubsection "Time Complexity Proof"

lemma time_merge_tm:
  "time (merge_tm f xs ys) \<le> length xs + length ys + 1"
  by (induction f xs ys rule: merge_tm.induct) (auto simp: time_simps)

function mergesort_recurrence :: "nat \<Rightarrow> real" where
  "mergesort_recurrence 0 = 1"
| "mergesort_recurrence 1 = 1"
| "2 \<le> n \<Longrightarrow> mergesort_recurrence n = 4 + 3 * n + mergesort_recurrence (nat \<lfloor>real n / 2\<rfloor>) +
    mergesort_recurrence (nat \<lceil>real n / 2\<rceil>)"
  by force simp_all
termination by akra_bazzi_termination simp_all

lemma mergesort_recurrence_nonneg[simp]:
  "0 \<le> mergesort_recurrence n"
  by (induction n rule: mergesort_recurrence.induct) (auto simp del: One_nat_def)

lemma time_mergesort_conv_mergesort_recurrence:
  "time (mergesort_tm f xs) \<le> mergesort_recurrence (length xs)"
proof (induction f xs rule: mergesort_tm.induct)
  case (1 f)
  thus ?case by (auto simp: time_simps)
next
  case (2 f x)
  thus ?case using mergesort_recurrence.simps(2) by (auto simp: time_simps)
next
  case (3 f x y xs')

  define xs where "xs = x # y # xs'"
  define n where "n = length xs"
  obtain l r where lr_def: "(l, r) = split_at (n div 2) xs"
    using prod.collapse by blast
  define l' where "l' = mergesort f l"
  define r' where "r' = mergesort f r"
  note defs = xs_def n_def lr_def l'_def r'_def

  have IHL: "time (mergesort_tm f l) \<le> mergesort_recurrence (length l)"
    using defs "3.IH"(1) by (auto simp: length_eq_val_length_tm split_at_eq_val_split_at_tm)
  have IHR: "time (mergesort_tm f r) \<le> mergesort_recurrence (length r)"
    using defs "3.IH"(2) by (auto simp: length_eq_val_length_tm split_at_eq_val_split_at_tm)

  have *: "length l = n div 2" "length r = n - n div 2"
    using defs by (auto simp: split_at_take_drop_conv)
  hence "(nat \<lfloor>real n / 2\<rfloor>) = length l" "(nat \<lceil>real n / 2\<rceil>) = length r"
    by linarith+
  hence IH: "time (mergesort_tm f l) \<le> mergesort_recurrence (nat \<lfloor>real n / 2\<rfloor>)"
            "time (mergesort_tm f r) \<le> mergesort_recurrence (nat \<lceil>real n / 2\<rceil>)"
    using IHL IHR by simp_all

  have "n = length l + length r"
    using * by linarith
  hence "time (merge_tm f l' r') \<le> n + 1"
    using time_merge_tm defs by (metis length_mergesort)

  have "time (mergesort_tm f xs) = 1 + time (length_tm xs) + time (split_at_tm (n div 2) xs) +
          time (mergesort_tm f l) + time (mergesort_tm f r) + time (merge_tm f l' r')"
    using defs by (auto simp add: time_simps length_eq_val_length_tm  mergesort_eq_val_mergesort_tm
                                  split_at_eq_val_split_at_tm
                        split: prod.split)
  also have "... \<le> 4 + 3 * n + time (mergesort_tm f l) + time (mergesort_tm f r)"
    using time_length_tm[of xs] time_split_at_tm[of "n div 2" xs] n_def \<open>time (merge_tm f l' r') \<le> n + 1\<close> by simp
  also have "... \<le> 4 + 3 * n + mergesort_recurrence (nat \<lfloor>real n / 2\<rfloor>) + mergesort_recurrence (nat \<lceil>real n / 2\<rceil>)"
    using IH by simp
  also have "... = mergesort_recurrence n"
    using defs by simp
  finally show ?case
    using defs by simp
qed

theorem mergesort_recurrence:
  "mergesort_recurrence \<in> \<Theta>(\<lambda>n. n * ln n)"
  by (master_theorem) auto

theorem time_mergesort_tm_bigo:
  "(\<lambda>xs. time (mergesort_tm f xs)) \<in> O[length going_to at_top]((\<lambda>n. n * ln n) o length)"
proof -
  have 0: "\<And>xs. time (mergesort_tm f xs) \<le> (mergesort_recurrence o length) xs"
    unfolding comp_def using time_mergesort_conv_mergesort_recurrence by blast
  show ?thesis
    using bigo_measure_trans[OF 0] by (simp add: bigthetaD1 mergesort_recurrence)
qed

subsubsection "Code Export"

lemma merge_xs_Nil[simp]:
  "merge f xs [] = xs"
  by (cases xs) auto

fun merge_it' :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "merge_it' f acc [] [] = rev acc"
| "merge_it' f acc (x#xs) [] = merge_it' f (x#acc) xs []"
| "merge_it' f acc [] (y#ys) = merge_it' f (y#acc) ys []"
| "merge_it' f acc (x#xs) (y#ys) = (
    if f x \<le> f y then
      merge_it' f (x#acc) xs (y#ys)
    else
      merge_it' f (y#acc) (x#xs) ys
  )"

definition merge_it :: "('b \<Rightarrow> 'a::linorder) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "merge_it f xs ys = merge_it' f [] xs ys"

lemma merge_conv_merge_it':
  "rev acc @ merge f xs ys = merge_it' f acc xs ys"
  by (induction f acc xs ys rule: merge_it'.induct) auto

lemma merge_conv_merge_it[code_unfold]:
  "merge f xs ys = merge_it f xs ys"
  unfolding merge_it_def using merge_conv_merge_it' rev.simps(1) append_Nil by metis

subsection "Minimal Distance"

definition sparse :: "real \<Rightarrow> point set \<Rightarrow> bool" where
  "sparse \<delta> ps \<longleftrightarrow> (\<forall>p\<^sub>0 \<in> ps. \<forall>p\<^sub>1 \<in> ps. p\<^sub>0 \<noteq> p\<^sub>1 \<longrightarrow> \<delta> \<le> dist p\<^sub>0 p\<^sub>1)"

lemma sparse_identity:
  assumes "sparse \<delta> (set ps)" "\<forall>p \<in> set ps. \<delta> \<le> dist p\<^sub>0 p"
  shows "sparse \<delta> (set (p\<^sub>0 # ps))"
  using assms by (simp add: dist_commute sparse_def)

lemma sparse_update:
  assumes "sparse \<delta> (set ps)"
  assumes "dist p\<^sub>0 p\<^sub>1 \<le> \<delta>" "\<forall>p \<in> set ps. dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>0 p"
  shows "sparse (dist p\<^sub>0 p\<^sub>1) (set (p\<^sub>0 # ps))"
  using assms by (auto simp: dist_commute sparse_def, force+)

lemma sparse_mono:
  "sparse \<Delta> P \<Longrightarrow> \<delta> \<le> \<Delta> \<Longrightarrow> sparse \<delta> P"
  unfolding sparse_def by fastforce

subsection "Distance"

lemma dist_transform:
  fixes p :: point and \<delta> :: real and l :: int
  shows "dist p (l, snd p) < \<delta> \<longleftrightarrow> l - \<delta> < fst p \<and> fst p < l + \<delta>"
proof -
  have "dist p (l, snd p) = sqrt ((real_of_int (fst p) - l)\<^sup>2)"
    by (auto simp add: dist_prod_def dist_real_def prod.case_eq_if)
  thus ?thesis
    by auto
qed

fun dist_code :: "point \<Rightarrow> point \<Rightarrow> int" where
  "dist_code p\<^sub>0 p\<^sub>1 = (fst p\<^sub>0 - fst p\<^sub>1)\<^sup>2 + (snd p\<^sub>0 - snd p\<^sub>1)\<^sup>2"

lemma dist_eq_sqrt_dist_code:
  fixes p\<^sub>0 :: point
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (dist_code p\<^sub>0 p\<^sub>1)"
  by (auto simp: dist_prod_def dist_real_def split: prod.splits)

lemma dist_eq_dist_code_lt:
  fixes p\<^sub>0 :: point
  shows "dist p\<^sub>0 p\<^sub>1 < dist p\<^sub>2 p\<^sub>3 \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 < dist_code p\<^sub>2 p\<^sub>3"
  using dist_eq_sqrt_dist_code real_sqrt_less_iff by presburger

lemma dist_eq_dist_code_le:
  fixes p\<^sub>0 :: point
  shows "dist p\<^sub>0 p\<^sub>1 \<le> dist p\<^sub>2 p\<^sub>3 \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 \<le> dist_code p\<^sub>2 p\<^sub>3"
  using dist_eq_sqrt_dist_code real_sqrt_le_iff by presburger

lemma dist_eq_dist_code_abs_lt:
  fixes p\<^sub>0 :: point
  shows "\<bar>c\<bar> < dist p\<^sub>0 p\<^sub>1 \<longleftrightarrow> c\<^sup>2 < dist_code p\<^sub>0 p\<^sub>1"
  using dist_eq_sqrt_dist_code
  by (metis of_int_less_of_int_power_cancel_iff real_sqrt_abs real_sqrt_less_iff)

lemma dist_eq_dist_code_abs_le:
  fixes p\<^sub>0 :: point
  shows "dist p\<^sub>0 p\<^sub>1 \<le> \<bar>c\<bar> \<longleftrightarrow> dist_code p\<^sub>0 p\<^sub>1 \<le> c\<^sup>2"
  using dist_eq_sqrt_dist_code
  by (metis of_int_power_le_of_int_cancel_iff real_sqrt_abs real_sqrt_le_iff)

declare dist_code.simps [simp del]

subsection "Brute Force Closest Pair Algorithm"

subsubsection "Functional Correctness Proof"

fun find_closest_bf_tm :: "point \<Rightarrow> point list \<Rightarrow> point tm" where
  "find_closest_bf_tm _ [] =1 return undefined"
| "find_closest_bf_tm _ [p] =1 return p"
| "find_closest_bf_tm p (p\<^sub>0 # ps) =1 (
    do {
      p\<^sub>1 <- find_closest_bf_tm p ps;
      if dist p p\<^sub>0 < dist p p\<^sub>1 then
        return p\<^sub>0
      else
        return p\<^sub>1
    }
  )"

fun find_closest_bf :: "point \<Rightarrow> point list \<Rightarrow> point" where
  "find_closest_bf _ [] = undefined"
| "find_closest_bf _ [p] = p"
| "find_closest_bf p (p\<^sub>0 # ps) = (
    let p\<^sub>1 = find_closest_bf p ps in
    if dist p p\<^sub>0 < dist p p\<^sub>1 then
      p\<^sub>0
    else
      p\<^sub>1
  )"

lemma find_closest_bf_eq_val_find_closest_bf_tm:
  "val (find_closest_bf_tm p ps) = find_closest_bf p ps"
  by (induction p ps rule: find_closest_bf.induct) (auto simp: Let_def)

lemma find_closest_bf_set:
  "0 < length ps \<Longrightarrow> find_closest_bf p ps \<in> set ps"
  by (induction p ps rule: find_closest_bf.induct)
     (auto simp: Let_def split: prod.splits if_splits)

lemma find_closest_bf_dist:
  "\<forall>q \<in> set ps. dist p (find_closest_bf p ps) \<le> dist p q"
  by (induction p ps rule: find_closest_bf.induct)
     (auto split: prod.splits)

fun closest_pair_bf_tm :: "point list \<Rightarrow> (point \<times> point) tm" where
  "closest_pair_bf_tm [] =1 return undefined"
| "closest_pair_bf_tm [_] =1 return undefined"
| "closest_pair_bf_tm [p\<^sub>0, p\<^sub>1] =1 return (p\<^sub>0, p\<^sub>1)"
| "closest_pair_bf_tm (p\<^sub>0 # ps) =1 (
    do {
      (c\<^sub>0::point, c\<^sub>1::point) <- closest_pair_bf_tm ps;
      p\<^sub>1 <- find_closest_bf_tm p\<^sub>0 ps;
      if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
        return (c\<^sub>0, c\<^sub>1)
      else
        return (p\<^sub>0, p\<^sub>1)
    }
  )"

fun closest_pair_bf :: "point list \<Rightarrow> (point * point)" where
  "closest_pair_bf [] = undefined"
| "closest_pair_bf [_] = undefined"
| "closest_pair_bf [p\<^sub>0, p\<^sub>1] = (p\<^sub>0, p\<^sub>1)"
| "closest_pair_bf (p\<^sub>0 # ps) = (
    let (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps in
    let p\<^sub>1 = find_closest_bf p\<^sub>0 ps in
    if dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 then
      (c\<^sub>0, c\<^sub>1)
    else
      (p\<^sub>0, p\<^sub>1)
  )"

lemma closest_pair_bf_eq_val_closest_pair_bf_tm:
  "val (closest_pair_bf_tm ps) = closest_pair_bf ps"
  by (induction ps rule: closest_pair_bf.induct)
     (auto simp: Let_def find_closest_bf_eq_val_find_closest_bf_tm split: prod.split)

lemma closest_pair_bf_c0:
  "1 < length ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>0 \<in> set ps"
  by (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
     (auto simp: Let_def find_closest_bf_set split: if_splits prod.splits)

lemma closest_pair_bf_c1:
  "1 < length ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>1 \<in> set ps"
proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
    using prod.collapse by blast
  define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
  note defs = c\<^sub>0_def p\<^sub>1_def
  have "c\<^sub>1 \<in> set ?ps"
    using "4.IH" defs by simp
  moreover have "p\<^sub>1 \<in> set ?ps"
    using find_closest_bf_set defs by blast
  ultimately show ?case
    using "4.prems"(2) defs by (auto simp: Let_def split: prod.splits if_splits)
qed auto

lemma closest_pair_bf_c0_ne_c1:
  "1 < length ps \<Longrightarrow> distinct ps \<Longrightarrow> (c\<^sub>0, c\<^sub>1) = closest_pair_bf ps \<Longrightarrow> c\<^sub>0 \<noteq> c\<^sub>1"
proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
    using prod.collapse by blast
  define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
  note defs = c\<^sub>0_def p\<^sub>1_def
  have "c\<^sub>0 \<noteq> c\<^sub>1"
    using "4.IH" "4.prems"(2) defs by simp
  moreover have "p\<^sub>0 \<noteq> p\<^sub>1"
    using find_closest_bf_set "4.prems"(2) defs
    by (metis distinct.simps(2) length_pos_if_in_set list.set_intros(1))
  ultimately show ?case
    using "4.prems"(3) defs by (auto simp: Let_def split: prod.splits if_splits)
qed auto

lemmas closest_pair_bf_c0_c1 = closest_pair_bf_c0 closest_pair_bf_c1 closest_pair_bf_c0_ne_c1

lemma closest_pair_bf_dist:
  assumes "1 < length ps" "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ps"
  shows "sparse (dist c\<^sub>0 c\<^sub>1) (set ps)"
  using assms
proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 rule: closest_pair_bf.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  obtain c\<^sub>0 c\<^sub>1 where c\<^sub>0_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
    using prod.collapse by blast
  define p\<^sub>1 where p\<^sub>1_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
  note defs = c\<^sub>0_def p\<^sub>1_def
  hence IH: "sparse (dist c\<^sub>0 c\<^sub>1) (set ?ps)"
    using 4 c\<^sub>0_def by simp
  have *: "\<forall>p \<in> set ?ps. (dist p\<^sub>0 p\<^sub>1) \<le> dist p\<^sub>0 p"
    using find_closest_bf_dist defs by blast
  show ?case
  proof (cases "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1")
    case True
    hence "\<forall>p \<in> set ?ps. dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p"
      using * by auto
    hence "sparse (dist c\<^sub>0 c\<^sub>1) (set (p\<^sub>0 # ?ps))"
      using sparse_identity IH by blast
    thus ?thesis
      using True "4.prems" defs by (auto split: prod.splits)
  next
    case False
    hence "sparse (dist p\<^sub>0 p\<^sub>1) (set (p\<^sub>0 # ?ps))"
      using sparse_update[of "dist c\<^sub>0 c\<^sub>1" ?ps p\<^sub>0 p\<^sub>1] IH * defs by argo
    thus ?thesis
      using False "4.prems" defs by (auto split: prod.splits)
  qed
qed (auto simp: dist_commute sparse_def)

subsubsection "Time Complexity Proof"

lemma time_find_closest_bf_tm:
  "time (find_closest_bf_tm p ps) \<le> length ps + 1"
  by (induction p ps rule: find_closest_bf_tm.induct) (auto simp: time_simps)

lemma time_closest_pair_bf_tm:
  "time (closest_pair_bf_tm ps) \<le> length ps * length ps + 1"
proof (induction ps rule: closest_pair_bf_tm.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  have "time (closest_pair_bf_tm (p\<^sub>0 # ?ps)) = 1 + time (find_closest_bf_tm p\<^sub>0 ?ps) + time (closest_pair_bf_tm ?ps)"
    by (auto simp: time_simps split: prod.split)
  also have "... \<le> 2 + length ?ps + time (closest_pair_bf_tm ?ps)"
    using time_find_closest_bf_tm[of p\<^sub>0 ?ps] by simp
  also have "... \<le> 2 + length ?ps + length ?ps * length ?ps + 1"
    using "4.IH" by simp
  also have "... \<le> length (p\<^sub>0 # ?ps) * length (p\<^sub>0 # ?ps) + 1"
    by auto
  finally show ?case
    by blast
qed (auto simp: time_simps)

subsubsection "Code Export"

fun find_closest_bf_code :: "point \<Rightarrow> point list \<Rightarrow> (int * point)" where
  "find_closest_bf_code p [] = undefined"
| "find_closest_bf_code p [p\<^sub>0] = (dist_code p p\<^sub>0, p\<^sub>0)"
| "find_closest_bf_code p (p\<^sub>0 # ps) = (
    let (\<delta>\<^sub>1, p\<^sub>1) = find_closest_bf_code p ps in
    let \<delta>\<^sub>0 = dist_code p p\<^sub>0 in
    if \<delta>\<^sub>0 < \<delta>\<^sub>1 then
      (\<delta>\<^sub>0, p\<^sub>0)
    else
      (\<delta>\<^sub>1, p\<^sub>1)
  )"

lemma find_closest_bf_code_dist_eq:
  "0 < length ps \<Longrightarrow> (\<delta>, c) = find_closest_bf_code p ps \<Longrightarrow> \<delta> = dist_code p c"
  by (induction p ps rule: find_closest_bf_code.induct)
     (auto simp: Let_def split: prod.splits if_splits)

lemma find_closest_bf_code_eq:
  "0 < length ps \<Longrightarrow> c = find_closest_bf p ps \<Longrightarrow> (\<delta>', c') = find_closest_bf_code p ps \<Longrightarrow> c = c'"
proof (induction p ps arbitrary: c \<delta>' c' rule: find_closest_bf.induct)
  case (3 p p\<^sub>0 p\<^sub>2 ps)
  define \<delta>\<^sub>0 \<delta>\<^sub>0' where \<delta>\<^sub>0_def: "\<delta>\<^sub>0 = dist p p\<^sub>0" "\<delta>\<^sub>0' = dist_code p p\<^sub>0"
  obtain \<delta>\<^sub>1 p\<^sub>1 \<delta>\<^sub>1' p\<^sub>1' where \<delta>\<^sub>1_def: "\<delta>\<^sub>1 = dist p p\<^sub>1" "p\<^sub>1 = find_closest_bf p (p\<^sub>2 # ps)"
    "(\<delta>\<^sub>1', p\<^sub>1') = find_closest_bf_code p (p\<^sub>2 # ps)"
    using prod.collapse by blast+
  note defs = \<delta>\<^sub>0_def \<delta>\<^sub>1_def
  have *: "p\<^sub>1 = p\<^sub>1'"
    using "3.IH" defs by simp
  hence "\<delta>\<^sub>0 < \<delta>\<^sub>1 \<longleftrightarrow> \<delta>\<^sub>0' < \<delta>\<^sub>1'"
    using find_closest_bf_code_dist_eq[of "p\<^sub>2 # ps" \<delta>\<^sub>1' p\<^sub>1' p]
          dist_eq_dist_code_lt defs
    by simp
  thus ?case
    using "3.prems"(2,3) * defs by (auto split: prod.splits)
qed auto

declare find_closest_bf_code.simps [simp del]

fun closest_pair_bf_code :: "point list \<Rightarrow> (int * point * point)" where
  "closest_pair_bf_code [] = undefined"
| "closest_pair_bf_code [p\<^sub>0] = undefined"
| "closest_pair_bf_code [p\<^sub>0, p\<^sub>1] = (dist_code p\<^sub>0 p\<^sub>1, p\<^sub>0, p\<^sub>1)"
| "closest_pair_bf_code (p\<^sub>0 # ps) = (
    let (\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ps in
    let (\<delta>\<^sub>p, p\<^sub>1) = find_closest_bf_code p\<^sub>0 ps in
    if \<delta>\<^sub>c \<le> \<delta>\<^sub>p then
      (\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1)
    else
      (\<delta>\<^sub>p, p\<^sub>0, p\<^sub>1)
  )"

lemma closest_pair_bf_code_dist_eq:
  "1 < length ps \<Longrightarrow> (\<delta>, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ps \<Longrightarrow> \<delta> = dist_code c\<^sub>0 c\<^sub>1"
proof (induction ps arbitrary: \<delta> c\<^sub>0 c\<^sub>1 rule: closest_pair_bf_code.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  obtain \<delta>\<^sub>c c\<^sub>0 c\<^sub>1 where \<delta>\<^sub>c_def: "(\<delta>\<^sub>c, c\<^sub>0, c\<^sub>1) = closest_pair_bf_code ?ps"
    by (metis prod_cases3)
  obtain \<delta>\<^sub>p p\<^sub>1 where \<delta>\<^sub>p_def: "(\<delta>\<^sub>p, p\<^sub>1) = find_closest_bf_code p\<^sub>0 ?ps"
    using prod.collapse by blast
  note defs = \<delta>\<^sub>c_def \<delta>\<^sub>p_def
  have "\<delta>\<^sub>c = dist_code c\<^sub>0 c\<^sub>1"
    using "4.IH" defs by simp
  moreover have "\<delta>\<^sub>p = dist_code p\<^sub>0 p\<^sub>1"
    using find_closest_bf_code_dist_eq defs by blast
  ultimately show ?case
    using "4.prems"(2) defs by (auto split: prod.splits if_splits)
qed auto

lemma closest_pair_bf_code_eq:
  assumes "1 < length ps"
  assumes "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ps" "(\<delta>', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code ps"
  shows "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
  using assms
proof (induction ps arbitrary: c\<^sub>0 c\<^sub>1 \<delta>' c\<^sub>0' c\<^sub>1' rule: closest_pair_bf_code.induct)
  case (4 p\<^sub>0 p\<^sub>2 p\<^sub>3 ps)
  let ?ps = "p\<^sub>2 # p\<^sub>3 # ps"
  obtain c\<^sub>0 c\<^sub>1 \<delta>\<^sub>c' c\<^sub>0' c\<^sub>1' where \<delta>\<^sub>c_def: "(c\<^sub>0, c\<^sub>1) = closest_pair_bf ?ps"
    "(\<delta>\<^sub>c', c\<^sub>0', c\<^sub>1') = closest_pair_bf_code ?ps"
    by (metis prod_cases3)
  obtain p\<^sub>1 \<delta>\<^sub>p' p\<^sub>1' where \<delta>\<^sub>p_def: "p\<^sub>1 = find_closest_bf p\<^sub>0 ?ps"
    "(\<delta>\<^sub>p', p\<^sub>1') = find_closest_bf_code p\<^sub>0 ?ps"
    using prod.collapse by blast
  note defs = \<delta>\<^sub>c_def \<delta>\<^sub>p_def
  have A: "c\<^sub>0 = c\<^sub>0' \<and> c\<^sub>1 = c\<^sub>1'"
    using "4.IH" defs by simp
  moreover have B: "p\<^sub>1 = p\<^sub>1'"
    using find_closest_bf_code_eq defs by blast
  moreover have "\<delta>\<^sub>c' = dist_code c\<^sub>0' c\<^sub>1'"
    using defs closest_pair_bf_code_dist_eq[of ?ps] by simp
  moreover have "\<delta>\<^sub>p' = dist_code p\<^sub>0 p\<^sub>1'"
    using defs find_closest_bf_code_dist_eq by blast
  ultimately have "dist c\<^sub>0 c\<^sub>1 \<le> dist p\<^sub>0 p\<^sub>1 \<longleftrightarrow> \<delta>\<^sub>c' \<le> \<delta>\<^sub>p'"
    by (simp add: dist_eq_dist_code_le)
  thus ?case
    using "4.prems"(2,3) defs A B by (auto simp: Let_def split: prod.splits)
qed auto

subsection "Geometry"

subsubsection "Band Filter"

lemma set_band_filter_aux:
  fixes \<delta> :: real and ps :: "point list"
  assumes "p\<^sub>0 \<in> ps\<^sub>L" "p\<^sub>1 \<in> ps\<^sub>R" "p\<^sub>0 \<noteq> p\<^sub>1" "dist p\<^sub>0 p\<^sub>1 < \<delta>" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
  assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
  assumes "ps' = filter (\<lambda>p. l - \<delta> < fst p \<and> fst p < l + \<delta>) ps"
  shows "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
proof (rule ccontr)
  assume "\<not> (p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps')"
  then consider (A) "p\<^sub>0 \<notin> set ps' \<and> p\<^sub>1 \<notin> set ps'"
              | (B) "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<notin> set ps'"
              | (C) "p\<^sub>0 \<notin> set ps' \<and> p\<^sub>1 \<in> set ps'"
    by blast
  thus False
  proof cases
    case A
    hence "fst p\<^sub>0 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>0" "fst p\<^sub>1 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>1"
      using assms(1,2,5,8) by auto
    hence "fst p\<^sub>0 \<le> l - \<delta>" "l + \<delta> \<le> fst p\<^sub>1"
      using assms(1,2,6,7) by force+
    hence "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
      using dist_real_def by simp
    hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
      using dist_fst_le[of p\<^sub>0 p\<^sub>1] by (auto split: prod.splits)
    then show ?thesis
      using assms(4) by fastforce
  next
    case B
    hence "fst p\<^sub>1 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>1"
      using assms(2,5,8) by auto
    hence "l + \<delta> \<le> fst p\<^sub>1"
      using assms(2,7) by auto
    moreover have "fst p\<^sub>0 \<le> l"
      using assms(1,6) by simp
    ultimately have "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
      using dist_real_def by simp
    hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
      using dist_fst_le[of p\<^sub>0 p\<^sub>1] less_le_trans by (auto split: prod.splits)
    thus ?thesis
      using assms(4) by simp
  next
    case C
    hence "fst p\<^sub>0 \<le> l - \<delta> \<or> l + \<delta> \<le> fst p\<^sub>0"
      using assms(1,2,5,8) by auto
    hence "fst p\<^sub>0 \<le> l - \<delta>"
      using assms(1,6) by auto
    moreover have "l \<le> fst p\<^sub>1"
      using assms(2,7) by simp
    ultimately have "\<delta> \<le> dist (fst p\<^sub>0) (fst p\<^sub>1)"
      using dist_real_def by simp
    hence "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
      using dist_fst_le[of p\<^sub>0 p\<^sub>1] less_le_trans by (auto split: prod.splits)
    thus ?thesis
      using assms(4) by simp
  qed
qed

lemma set_band_filter:
  fixes \<delta> :: real and ps :: "point list"
  assumes "p\<^sub>0 \<in> set ps" "p\<^sub>1 \<in> set ps" "p\<^sub>0 \<noteq> p\<^sub>1" "dist p\<^sub>0 p\<^sub>1 < \<delta>" "set ps = ps\<^sub>L \<union> ps\<^sub>R"
  assumes "sparse \<delta> ps\<^sub>L" "sparse \<delta> ps\<^sub>R"
  assumes "\<forall>p \<in> ps\<^sub>L. fst p \<le> l" "\<forall>p \<in> ps\<^sub>R. l \<le> fst p"
  assumes "ps' = filter (\<lambda>p. l - \<delta> < fst p \<and> fst p < l + \<delta>) ps"
  shows "p\<^sub>0 \<in> set ps' \<and> p\<^sub>1 \<in> set ps'"
proof -
  have "p\<^sub>0 \<notin> ps\<^sub>L \<or> p\<^sub>1 \<notin> ps\<^sub>L" "p\<^sub>0 \<notin> ps\<^sub>R \<or> p\<^sub>1 \<notin> ps\<^sub>R"
    using assms(3,4,6,7) sparse_def by force+
  then consider (A) "p\<^sub>0 \<in> ps\<^sub>L \<and> p\<^sub>1 \<in> ps\<^sub>R" | (B) "p\<^sub>0 \<in> ps\<^sub>R \<and> p\<^sub>1 \<in> ps\<^sub>L"
    using assms(1,2,5) by auto
  thus ?thesis
  proof cases
    case A
    thus ?thesis
      using set_band_filter_aux assms(3,4,5,8,9,10) by (auto split: prod.splits)
  next
    case B
    moreover have "dist p\<^sub>1 p\<^sub>0 < \<delta>"
      using assms(4) dist_commute by metis
    ultimately show ?thesis
      using set_band_filter_aux assms(3)[symmetric] assms(5,8,9,10) by (auto split: prod.splits)
  qed
qed

subsubsection "2D-Boxes and Points"

lemma cbox_2D:
  fixes x\<^sub>0 :: real and y\<^sub>0 :: real
  shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) = { (x, y). x\<^sub>0 \<le> x \<and> x \<le> x\<^sub>1 \<and> y\<^sub>0 \<le> y \<and> y \<le> y\<^sub>1 }"
  by fastforce

lemma mem_cbox_2D:
  fixes x :: real and y :: real
  shows "x\<^sub>0 \<le> x \<and> x \<le> x\<^sub>1 \<and> y\<^sub>0 \<le> y \<and> y \<le> y\<^sub>1 \<longleftrightarrow> (x, y) \<in> cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1)"
  by fastforce

lemma cbox_top_un:
  fixes x\<^sub>0 :: real and y\<^sub>0 :: real
  assumes "y\<^sub>0 \<le> y\<^sub>1" "y\<^sub>1 \<le> y\<^sub>2"
  shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<union> cbox (x\<^sub>0, y\<^sub>1) (x\<^sub>1, y\<^sub>2) = cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>2)"
  using assms by auto

lemma cbox_right_un:
  fixes x\<^sub>0 :: real and y\<^sub>0 :: real
  assumes "x\<^sub>0 \<le> x\<^sub>1" "x\<^sub>1 \<le> x\<^sub>2"
  shows "cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<union> cbox (x\<^sub>1, y\<^sub>0) (x\<^sub>2, y\<^sub>1) = cbox (x\<^sub>0, y\<^sub>0) (x\<^sub>2, y\<^sub>1)"
  using assms by auto

lemma cbox_max_dist:
  assumes "p\<^sub>0 = (x, y)" "p\<^sub>1 = (x + \<delta>, y + \<delta>)"
  assumes "(x\<^sub>0, y\<^sub>0) \<in> cbox p\<^sub>0 p\<^sub>1" "(x\<^sub>1, y\<^sub>1) \<in> cbox p\<^sub>0 p\<^sub>1" "0 \<le> \<delta>"
  shows "dist (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) \<le> sqrt 2 * \<delta>"
proof -
  have X: "dist x\<^sub>0 x\<^sub>1 \<le> \<delta>"
    using assms dist_real_def by auto
  have Y: "dist y\<^sub>0 y\<^sub>1 \<le> \<delta>"
    using assms dist_real_def by auto

  have "dist (x\<^sub>0, y\<^sub>0) (x\<^sub>1, y\<^sub>1) = sqrt ((dist x\<^sub>0 x\<^sub>1)\<^sup>2 + (dist y\<^sub>0 y\<^sub>1)\<^sup>2)"
    using dist_Pair_Pair by auto
  also have "... \<le> sqrt (\<delta>\<^sup>2 + (dist y\<^sub>0 y\<^sub>1)\<^sup>2)"
    using X power_mono by fastforce
  also have "... \<le> sqrt (\<delta>\<^sup>2 + \<delta>\<^sup>2)"
    using Y power_mono by fastforce
  also have "... = sqrt 2 * sqrt (\<delta>\<^sup>2)"
    using real_sqrt_mult by simp
  also have "... = sqrt 2 * \<delta>"
    using assms(5) by simp
  finally show ?thesis .
qed

subsubsection "Pigeonhole Argument"

lemma card_le_1_if_pairwise_eq:
  assumes "\<forall>x \<in> S. \<forall>y \<in> S. x = y"
  shows "card S \<le> 1"
proof (rule ccontr)
  assume "\<not> card S \<le> 1"
  hence "2 \<le> card S"
    by simp
  then obtain T where *: "T \<subseteq> S \<and> card T = 2"
    using ex_card by metis
  then obtain x y where "x \<in> T \<and> y \<in> T \<and> x \<noteq> y"
    using card_2_exists by metis
  then show False
    using * assms by blast
qed

lemma card_Int_if_either_in:
  assumes "\<forall>x \<in> S. \<forall>y \<in> S. x = y \<or> x \<notin> T \<or> y \<notin> T"
  shows "card (S \<inter> T) \<le> 1"
proof (rule ccontr)
  assume "\<not> (card (S \<inter> T) \<le> 1)"
  then obtain x y where *: "x \<in> S \<inter> T \<and> y \<in> S \<inter> T \<and> x \<noteq> y"
    by (meson card_le_1_if_pairwise_eq)
  hence "x \<in> T" "y \<in> T"
    by simp_all
  moreover have "x \<notin> T \<or> y \<notin> T"
    using assms * by auto
  ultimately show False
    by blast
qed

lemma card_Int_Un_le_Sum_card_Int:
  assumes "finite S"
  shows "card (A \<inter> \<Union>S) \<le> (\<Sum>B \<in> S. card (A \<inter> B))"
  using assms
proof (induction "card S" arbitrary: S)
  case (Suc n)
  then obtain B T where *: "S = { B } \<union> T" "card T = n" "B \<notin> T"
    by (metis card_Suc_eq Suc_eq_plus1 insert_is_Un)
  hence "card (A \<inter> \<Union>S) = card (A \<inter> \<Union>({ B } \<union> T))"
    by blast
  also have "... \<le> card (A \<inter> B) + card (A \<inter> \<Union>T)"
    by (simp add: card_Un_le inf_sup_distrib1)
  also have "... \<le> card (A \<inter> B) + (\<Sum>B \<in> T. card (A \<inter> B))"
    using Suc * by simp
  also have "... \<le> (\<Sum>B \<in> S. card (A \<inter> B))"
    using Suc.prems * by simp
  finally show ?case .
qed simp

lemma pigeonhole:
  assumes "finite T" "S \<subseteq> \<Union>T" "card T < card S"
  shows "\<exists>x \<in> S. \<exists>y \<in> S. \<exists>X \<in> T. x \<noteq> y \<and> x \<in> X \<and> y \<in> X"
proof (rule ccontr)
  assume "\<not> (\<exists>x \<in> S. \<exists>y \<in> S. \<exists>X \<in> T. x \<noteq> y \<and> x \<in> X \<and> y \<in> X)"
  hence *: "\<forall>X \<in> T. card (S \<inter> X) \<le> 1"
    using card_Int_if_either_in by metis
  have "card T < card (S \<inter> \<Union>T)"
    using Int_absorb2 assms by fastforce
  also have "... \<le> (\<Sum>X \<in> T. card (S \<inter> X))"
    using assms(1) card_Int_Un_le_Sum_card_Int by blast
  also have "... \<le> card T"
    using * sum_mono by fastforce
  finally show False by simp
qed

subsubsection "Delta Sparse Points within a Square"

lemma max_points_square:
  assumes "\<forall>p \<in> ps. p \<in> cbox (x, y) (x + \<delta>, y + \<delta>)" "sparse \<delta> ps" "0 \<le> \<delta>"
  shows "card ps \<le> 4"
proof (cases "\<delta> = 0")
  case True
  hence "{ (x, y) } = cbox (x, y) (x + \<delta>, y + \<delta>)"
    using cbox_def by simp
  hence "\<forall>p \<in> ps. p = (x, y)"
    using assms(1) by blast
  hence "\<forall>p \<in> ps. \<forall>q \<in> ps. p = q"
    apply (auto split: prod.splits) by (metis of_int_eq_iff)+
  thus ?thesis
    using card_le_1_if_pairwise_eq by force
next
  case False
  hence \<delta>: "0 < \<delta>"
    using assms(3) by simp
  show ?thesis
  proof (rule ccontr)
    assume A: "\<not> (card ps \<le> 4)"
    define PS where PS_def: "PS = (\<lambda>(x, y). (real_of_int x, real_of_int y)) ` ps"
    have "inj_on (\<lambda>(x, y). (real_of_int x, real_of_int y)) ps"
      using inj_on_def by fastforce
    hence *: "\<not> (card PS \<le> 4)"
      using A PS_def by (simp add: card_image)

    let ?x' = "x + \<delta> / 2"
    let ?y' = "y + \<delta> / 2"

    let ?ll = "cbox ( x ,  y ) (?x'   , ?y'   )"
    let ?lu = "cbox ( x , ?y') (?x'   ,  y + \<delta>)"
    let ?rl = "cbox (?x',  y ) ( x + \<delta>, ?y'   )"
    let ?ru = "cbox (?x', ?y') ( x + \<delta>,  y + \<delta>)"

    let ?sq = "{ ?ll, ?lu, ?rl, ?ru }"

    have card_le_4: "card ?sq \<le> 4"
      by (simp add: card_insert_le_m1)

    have "cbox (x, y) (?x', y + \<delta>) = ?ll \<union> ?lu"
      using cbox_top_un assms(3) by auto
    moreover have "cbox (?x', y) (x + \<delta>, y + \<delta>) = ?rl \<union> ?ru"
      using cbox_top_un assms(3) by auto
    moreover have "cbox (x, y) (?x', y + \<delta>) \<union> cbox (?x', y) (x + \<delta>, y + \<delta>) = cbox (x, y) (x + \<delta>, y + \<delta>)"
      using cbox_right_un assms(3) by simp
    ultimately have "?ll \<union> ?lu \<union> ?rl \<union> ?ru = cbox (x, y) (x + \<delta>, y + \<delta>)"
      by blast

    hence "PS \<subseteq> \<Union>(?sq)"
      using assms(1) PS_def by (auto split: prod.splits)
    moreover have "card ?sq < card PS"
      using * card_insert_le_m1 card_le_4 by linarith
    moreover have "finite ?sq"
      by simp
    ultimately have "\<exists>p\<^sub>0 \<in> PS. \<exists>p\<^sub>1 \<in> PS. \<exists>S \<in> ?sq. (p\<^sub>0 \<noteq> p\<^sub>1 \<and> p\<^sub>0 \<in> S \<and> p\<^sub>1 \<in> S)"
      using pigeonhole[of ?sq PS] by blast
    then obtain S p\<^sub>0 p\<^sub>1 where #: "p\<^sub>0 \<in> PS" "p\<^sub>1 \<in> PS" "S \<in> ?sq" "p\<^sub>0 \<noteq> p\<^sub>1" "p\<^sub>0 \<in> S" "p\<^sub>1 \<in> S"
      by blast

    have D: "0 \<le> \<delta> / 2"
      using assms(3) by simp
    have LL: "\<forall>p\<^sub>0 \<in> ?ll. \<forall>p\<^sub>1 \<in> ?ll. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
      using cbox_max_dist[of "(x, y)" x y "(?x', ?y')" "\<delta> / 2"] D by auto
    have LU: "\<forall>p\<^sub>0 \<in> ?lu. \<forall>p\<^sub>1 \<in> ?lu. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
      using cbox_max_dist[of "(x, ?y')" x ?y' "(?x', y + \<delta>)" "\<delta> / 2"] D by auto
    have RL: "\<forall>p\<^sub>0 \<in> ?rl. \<forall>p\<^sub>1 \<in> ?rl. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
      using cbox_max_dist[of "(?x', y)" ?x' y "(x + \<delta>, ?y')" "\<delta> / 2"] D by auto
    have RU: "\<forall>p\<^sub>0 \<in> ?ru. \<forall>p\<^sub>1 \<in> ?ru. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
      using cbox_max_dist[of "(?x', ?y')" ?x' ?y' "(x + \<delta>, y + \<delta>)" "\<delta> / 2"] D by auto

    have "\<forall>p\<^sub>0 \<in> S. \<forall>p\<^sub>1 \<in> S. dist p\<^sub>0 p\<^sub>1 \<le> sqrt 2 * (\<delta> / 2)"
      using # LL LU RL RU by blast
    hence "dist p\<^sub>0 p\<^sub>1 \<le> (sqrt 2 / 2) * \<delta>"
      using # by simp
    moreover have "(sqrt 2 / 2) * \<delta> < \<delta>"
      using sqrt2_less_2 \<delta> by simp
    ultimately have "dist p\<^sub>0 p\<^sub>1 < \<delta>"
      by simp
    moreover have "\<delta> \<le> dist p\<^sub>0 p\<^sub>1"
      using assms(2) # sparse_def PS_def by auto
    ultimately show False
      by simp
  qed
qed

end