theory border_algebra
  imports operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Border algebra\<close>
(**We define a border algebra in an analogous fashion to the well-known closure/interior algebras.
We also verify a few interesting properties.*)

(**Declares a primitive (unconstrained) border operation and defines others from it.*)
consts \<B>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<I>\<^sub>B \<B>" (**interior*)
abbreviation "\<C> \<equiv> \<C>\<^sub>B \<B>" (**closure*)
abbreviation "\<F> \<equiv> \<F>\<^sub>B \<B>" (**frontier*)

subsection \<open>Basic properties\<close>

(**Verifies minimal conditions under which operators resulting from conversion functions coincide.*)
lemma ICdual:  "\<I> \<^bold>\<equiv> \<C>\<^sup>d" by (simp add: Cl_br_def Int_br_def dual_def equal_op_def conn)
lemma ICdual': "\<C> \<^bold>\<equiv> \<I>\<^sup>d"  by (simp add: Cl_br_def Int_br_def dual_def equal_op_def conn)
lemma FI_rel: "Br_1 \<B> \<Longrightarrow> \<F> \<^bold>\<equiv> \<F>\<^sub>I \<I>" using Fr_br_def Fr_int_def Int_br_def equal_op_def by (smt Br_5b_def PB5b dual_def conn)
lemma IF_rel: "Br_1 \<B> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>F \<F>" using Br_5b_def Fr_br_def Int_br_def Int_fr_def PB5b unfolding equal_op_def conn by fastforce
lemma FC_rel: "Br_1 \<B> \<Longrightarrow> \<F> \<^bold>\<equiv> \<F>\<^sub>C \<C>" using Br_5b_def Cl_br_def Fr_br_def Fr_cl_def PB5b unfolding equal_op_def conn by fastforce
lemma CF_rel: "Br_1 \<B> \<Longrightarrow> \<C> \<^bold>\<equiv> \<C>\<^sub>F \<F>" using Br_5b_def Cl_br_def Cl_fr_def Fr_br_def PB5b unfolding equal_op_def conn by fastforce

(**Fixed-point and other operators are interestingly related.*)
lemma fp1: "Br_1 \<B> \<Longrightarrow> \<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" using Br_5b_def Int_br_def PB5b unfolding equal_op_def conn by fastforce
lemma fp2: "Br_1 \<B> \<Longrightarrow> \<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using Br_5b_def Int_br_def PB5b conn equal_op_def by fastforce
lemma fp3: "Br_1 \<B> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" using Br_5c_def Cl_br_def PB5c dual_def unfolding equal_op_def conn by fastforce
lemma fp4: "Br_1 \<B> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "Br_1 \<B> \<Longrightarrow> \<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" by (smt Br_5b_def Cl_br_def Fr_br_def PB5b equal_op_def conn)

(**Define some fixed-point predicates and prove some properties.*)
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Br_1 \<B> \<Longrightarrow> Br_3 \<B> \<Longrightarrow> \<forall>A. Op(\<I> A)" using IB4 IDEM_def by blast
lemma Cl_Closed: "Br_1 \<B> \<Longrightarrow> Br_3 \<B> \<Longrightarrow> \<forall>A. Cl(\<C> A)" using CB4 IDEM_def by blast
lemma Br_Border: "Br_1 \<B> \<Longrightarrow> \<forall>A. Br(\<B> A)" using IDEM_def PB6 by blast
(**In contrast, there is no analogous fixed-point result for frontier:*)
lemma "\<BB> \<B> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all border conditions*)

lemma OpCldual: "\<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" using Cl_br_def Int_br_def conn by auto
lemma ClOpdual: "\<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" using Cl_br_def Int_br_def conn by auto
lemma Fr_ClBr: "Br_1 \<B> \<Longrightarrow> \<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" by (metis BF_rel Br_fr_def CF_rel Cl_fr_def eq_ext' join_def meet_def)
lemma Cl_F: "Br_1 \<B> \<Longrightarrow> Br_3 \<B> \<Longrightarrow> \<forall>A. Cl(\<F> A)" by (metis CF_rel Cl_fr_def FB4 Fr_4_def eq_ext' join_def)

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/TBA/border_algebra.thy


theory Fixpoint
  imports Main
begin

context order
begin

definition endo_galois_connection :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_galois_connection f g \<equiv> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"

definition endo_lower_adjoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_lower_adjoint f \<equiv> \<exists>g. endo_galois_connection f g"

definition endo_upper_adjoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_upper_adjoint g \<equiv> \<exists>f. endo_galois_connection f g"

lemma endo_deflation: "endo_galois_connection f g \<Longrightarrow> f (g y) \<le> y"
  by (metis endo_galois_connection_def le_less)

lemma endo_inflation: "endo_galois_connection f g \<Longrightarrow> x \<le> g (f x)"
  by (metis endo_galois_connection_def le_less)

(* Sledgehammer can't seem to use mono due to it's sort constraints *)
definition isotone :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "isotone f \<equiv> \<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"

lemma isotone_is_mono: "isotone f \<Longrightarrow> mono f"
  by (metis (hide_lams, mono_tags) order_class.isotone_def order_class.mono_def)

lemma isotoneD: "\<lbrakk>isotone f; x \<le> y\<rbrakk> \<Longrightarrow> f x \<le> f y"
  by (metis isotone_def)

definition idempotent :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "idempotent f \<equiv> f \<circ> f = f"

lemma endo_lower_iso: "endo_galois_connection f g \<Longrightarrow> isotone f"
  by (metis endo_galois_connection_def endo_inflation isotone_def order_trans)

lemma endo_upper_iso: "endo_galois_connection f g \<Longrightarrow> isotone g"
  by (metis (lifting) endo_deflation endo_galois_connection_def isotone_def order_trans)

lemma endo_lower_comp: "endo_galois_connection f g \<Longrightarrow> f \<circ> g \<circ> f = f"
proof
  fix x
  assume "endo_galois_connection f g"
  thus "(f \<circ> g \<circ> f) x = f x"
    by (metis comp_apply endo_deflation endo_galois_connection_def endo_inflation isotoneD less_le less_le_not_le endo_lower_iso endo_upper_adjoint_def)
qed

lemma endo_upper_comp: "endo_galois_connection f g \<Longrightarrow> g \<circ> f \<circ> g = g"
proof
  fix x
  assume "endo_galois_connection f g"
  thus "(g \<circ> f \<circ> g) x = g x"
    by (metis (full_types) antisym endo_deflation endo_inflation isotone_def o_apply endo_upper_iso)
qed

lemma endo_upper_idempotency1: "endo_galois_connection f g \<Longrightarrow> idempotent (f \<circ> g)"
  by (metis idempotent_def o_assoc endo_upper_comp)

lemma endo_upper_idempotency2: "endo_galois_connection f g \<Longrightarrow> idempotent (g \<circ> f)"
  by (metis idempotent_def o_assoc endo_lower_comp)

lemma endo_galois_comp: assumes g1: "endo_galois_connection F G" and g2 :"endo_galois_connection H K"
  shows "endo_galois_connection (F \<circ> H) (K \<circ> G)"
  by (smt g1 g2 endo_galois_connection_def o_apply)

lemma endo_galois_id: "endo_galois_connection id id" by (metis endo_galois_connection_def id_def)

lemma endo_galois_isotone1: "endo_galois_connection f g \<Longrightarrow> isotone (g \<circ> f)"
  by (smt endo_galois_connection_def endo_inflation isotoneD isotone_def o_apply order_trans endo_upper_iso)

lemma endo_galois_isotone2: "endo_galois_connection f g \<Longrightarrow> isotone (f \<circ> g)"
  by (metis isotone_def endo_lower_iso o_apply endo_upper_iso)

lemma endo_cancel: assumes g: "endo_galois_connection f g" shows "f (g x) \<le> g (f x)"
  by (metis assms endo_deflation endo_inflation order_trans)

lemma endo_cancel_cor1: assumes g: "endo_galois_connection f g"
  shows "(g x = g y) \<longleftrightarrow> (f (g x) = f (g y))"
  by (metis assms endo_upper_comp o_apply)

lemma endo_cancel_cor2: assumes g: "endo_galois_connection f g"
  shows "(f x = f y) \<longleftrightarrow> (g (f x) = g (f y))"
  by (metis assms endo_lower_comp o_apply)

lemma endo_semi_inverse1: "endo_galois_connection f g \<Longrightarrow> f x = f (g (f x))"
  by (metis o_def endo_lower_comp)

lemma endo_semi_inverse2: "endo_galois_connection f g \<Longrightarrow> g x = g (f (g x))"
  by (metis o_def endo_upper_comp)

lemma endo_universal_mapping_property1:
  assumes a: "isotone g" and b: "\<forall>x. x \<le> g (f x)"
  and c: "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
  shows "endo_galois_connection f g"
  by (metis a b c endo_galois_connection_def isotoneD order_trans)

lemma endo_universal_mapping_property2:
  assumes a: "isotone f" and b: "\<forall>x. f (g x) \<le> x"
  and c: "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
  shows "endo_galois_connection f g"
  by (metis a b c endo_galois_connection_def isotoneD order_trans)

lemma endo_galois_ump2: "endo_galois_connection f g = (isotone f \<and> (\<forall>y. f (g y) \<le> y) \<and> (\<forall>x y. f x \<le> y \<longrightarrow> x \<le> g y))"
  by (metis endo_deflation endo_galois_connection_def endo_lower_iso endo_universal_mapping_property2)

lemma endo_galois_ump1: "endo_galois_connection f g = (isotone g \<and> (\<forall>x. x \<le> g (f x)) \<and> (\<forall>x y. x \<le> g y \<longrightarrow> f x \<le> y))"
  by (metis endo_galois_connection_def endo_inflation endo_universal_mapping_property1 endo_upper_iso)

(* +------------------------------------------------------------------------+
   | Theorem 4.10(a)                                                        |
   +------------------------------------------------------------------------+ *)

lemma endo_ore_galois:
  assumes"\<forall>x. x \<le> g (f x)" and "\<forall>x. f (g x) \<le> x"
  and "isotone f" and  "isotone g"
  shows "endo_galois_connection f g"
  by (metis assms isotoneD order_trans endo_universal_mapping_property1)

(* +------------------------------------------------------------------------+
   | Theorems 4.32(a) and 4.32(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma endo_perfect1: "endo_galois_connection f g \<Longrightarrow> g (f x) = x \<longleftrightarrow> x \<in> range g"
  by (metis (full_types) image_iff range_eqI endo_semi_inverse2)

lemma endo_perfect2: "endo_galois_connection f g \<Longrightarrow> f (g x) = x \<longleftrightarrow> x \<in> range f"
  by (metis (full_types) image_iff range_eqI endo_semi_inverse1)

end

definition pleq :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "pleq f g \<equiv> \<forall>x. f x \<le> g x"

definition galois_connection :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "galois_connection f g \<equiv> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"

lemma galoisD: "galois_connection f g \<Longrightarrow> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"
  by (simp add: galois_connection_def)

lemma rev_galoisD: "galois_connection f g \<Longrightarrow> \<forall>x y.  (x \<le> g y) \<longleftrightarrow> (f x \<le> y)"
  by (simp add: galois_connection_def)

definition lower_adjoint :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "lower_adjoint f \<equiv> \<exists>g. galois_connection f g"

definition upper_adjoint :: "('b::order \<Rightarrow> 'a::order) \<Rightarrow> bool" where
  "upper_adjoint g \<equiv> \<exists>f. galois_connection f g"

lemma deflation: "galois_connection f g \<Longrightarrow> f (g y) \<le> y"
  by (metis galois_connection_def le_less)

lemma deflationD: "galois_connection f g \<Longrightarrow> \<forall>y. f (g y) \<le> y"
  by (metis galois_connection_def le_less)

lemma inflation: "galois_connection f g \<Longrightarrow> x \<le> g (f x)"
  by (metis galois_connection_def le_less)

lemma inflationD: "galois_connection f g \<Longrightarrow> \<forall>x. x \<le> g (f x)"
  by (metis galois_connection_def le_less)

definition idempotent :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "idempotent f \<equiv> f \<circ> f = f"

lemma lower_iso: "galois_connection f g \<Longrightarrow> mono f"
  apply (frule galoisD)
  apply (auto simp add: mono_def)
  apply (drule inflationD)
  apply (erule_tac x = y in allE) back
  by (metis order_trans)

lemma upper_iso: "galois_connection f g \<Longrightarrow> mono g"
  apply (frule rev_galoisD)
  apply (auto simp add: mono_def)
  apply (drule deflationD)
  apply (erule_tac x = x in allE)
  by (metis order_trans)

lemma lower_comp: "galois_connection f g \<Longrightarrow> f \<circ> g \<circ> f = f"
proof
  fix x
  assume "galois_connection f g"
  thus "(f \<circ> g \<circ> f) x = f x"
    apply (simp add: galois_connection_def)
    by (metis `galois_connection f g` lower_iso monoE order_class.order.antisym order_refl)
qed

lemma upper_comp: "galois_connection f g \<Longrightarrow> g \<circ> f \<circ> g = g"
proof
  fix x
  assume "galois_connection f g"
  thus "(g \<circ> f \<circ> g) x = g x"
    apply (simp add: galois_connection_def)
    by (metis `galois_connection f g` monoE order_class.order.antisym order_refl upper_iso)
qed

lemma upper_idempotency1: "galois_connection f g \<Longrightarrow> idempotent (f \<circ> g)"
  by (metis idempotent_def o_assoc upper_comp)

lemma upper_idempotency2: "galois_connection f g \<Longrightarrow> idempotent (g \<circ> f)"
  by (metis idempotent_def o_assoc lower_comp)

lemma galois_comp: assumes g1: "galois_connection F G" and g2 :"galois_connection H K"
  shows "galois_connection (F \<circ> H) (K \<circ> G)"
  by (smt g1 g2 galois_connection_def o_apply)

lemma galois_id: "galois_connection id id"
  by (simp add: galois_connection_def)

lemma galois_isotone1: "galois_connection f g \<Longrightarrow> mono (g \<circ> f)"
  by (smt galois_connection_def inflation monoD mono_def o_apply order_trans upper_iso)

lemma galois_isotone2: "galois_connection f g \<Longrightarrow> mono (f \<circ> g)"
  by (metis mono_def lower_iso o_apply upper_iso)

lemma point_id1: "galois_connection f g \<Longrightarrow> id \<sqsubseteq> g \<circ> f"
  by (metis inflation id_apply o_apply pleq_def)

lemma point_id2: "galois_connection f g \<Longrightarrow> f \<circ> g \<sqsubseteq> id"
  by (metis deflation id_apply o_apply pleq_def)

lemma point_cancel: assumes g: "galois_connection f g" shows "f \<circ> g \<sqsubseteq> g \<circ> f" using g
  by (simp add: galois_connection_def o_def pleq_def) (metis g monoE order_refl upper_iso)

lemma cancel: assumes g: "galois_connection f g" shows "f (g x) \<le> g (f x)"
  by (metis assms deflation inflation order_trans)

lemma cancel_cor1: assumes g: "galois_connection f g"
  shows "(g x = g y) \<longleftrightarrow> (f (g x) = f (g y))"
  by (metis assms upper_comp o_apply)

lemma cancel_cor2: assumes g: "galois_connection f g"
  shows "(f x = f y) \<longleftrightarrow> (g (f x) = g (f y))"
  by (metis assms lower_comp o_apply)

lemma semi_inverse1: "galois_connection f g \<Longrightarrow> f x = f (g (f x))"
  by (metis o_def lower_comp)

lemma semi_inverse2: "galois_connection f g \<Longrightarrow> g x = g (f (g x))"
  by (metis o_def upper_comp)

lemma universal_mapping_property1:
  assumes a: "mono g" and b: "\<forall>x. x \<le> g (f x)"
  and c: "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
  shows "galois_connection f g"
  by (metis (full_types) a b c galois_connection_def monoD order_trans)

lemma universal_mapping_property2:
  assumes a: "mono f" and b: "\<forall>x. f (g x) \<le> x"
  and c: "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
  shows "galois_connection f g"
  by (metis (full_types) a b c galois_connection_def monoD order_trans)

lemma galois_ump2: "galois_connection f g = (mono f \<and> (\<forall>y. f (g y) \<le> y) \<and> (\<forall>x y. f x \<le> y \<longrightarrow> x \<le> g y))"
  by (metis deflation galois_connection_def lower_iso universal_mapping_property2)

lemma galois_ump1: "galois_connection f g = (mono g \<and> (\<forall>x. x \<le> g (f x)) \<and> (\<forall>x y. x \<le> g y \<longrightarrow> f x \<le> y))"
  by (metis galois_connection_def inflation universal_mapping_property1 upper_iso)

(* +------------------------------------------------------------------------+
   | Theorem 4.10(a)                                                        |
   +------------------------------------------------------------------------+ *)

lemma ore_galois:
  assumes"\<forall>x. x \<le> g (f x)" and "\<forall>x. f (g x) \<le> x"
  and "mono f" and  "mono g"
  shows "galois_connection f g"
  by (metis assms monoD order_trans universal_mapping_property1)

(* +------------------------------------------------------------------------+
   | Theorems 4.32(a) and 4.32(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma perfect1: "galois_connection f g \<Longrightarrow> g (f x) = x \<longleftrightarrow> x \<in> range g"
  by (metis (full_types) image_iff range_eqI semi_inverse2)

lemma perfect2: "galois_connection f g \<Longrightarrow> f (g x) = x \<longleftrightarrow> x \<in> range f"
  by (metis (full_types) image_iff range_eqI semi_inverse1)

(* Fixpoints *)

context order
begin

definition is_lpp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_lpp x f \<equiv> f x \<le> x \<and> (\<forall>y. f y \<le> y \<longrightarrow> x \<le> y)"

definition is_gpp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_gpp x f \<equiv> x \<le> f x \<and> (\<forall>y. y \<le> f y \<longrightarrow> y \<le> x)"

lemma lpp_unique: "\<lbrakk>is_lpp x f; is_lpp y f\<rbrakk> \<Longrightarrow> x = y"
  by (auto intro: antisym simp only: is_lpp_def)

lemma gpp_unique: "\<lbrakk>is_gpp x f; is_gpp y f\<rbrakk> \<Longrightarrow> x = y"
  by (auto intro: antisym simp only: is_gpp_def)

definition is_lfp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_lfp x f \<equiv> f x = x \<and> (\<forall>y. f y = y \<longrightarrow> x \<le> y)"

definition is_gfp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_gfp x f \<equiv> x = f x \<and> (\<forall>y. f y = y \<longrightarrow> y \<le> x)"

definition least_fixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<mu>") where
  "\<mu> f \<equiv> THE x. is_lfp x f"

notation least_fixpoint (binder "\<mu>" 10)

lemma lfp_eta: "(\<mu> x. f x) = \<mu> f" by simp

lemma lfp_equality: "is_lfp x f \<Longrightarrow> \<mu> f = x"
  by (metis (lifting) eq_iff is_lfp_def least_fixpoint_def the_equality)

lemma lpp_is_lfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_lpp x f \<Longrightarrow> is_lfp x f"
  by (auto intro: antisym simp add: is_lfp_def is_lpp_def)

definition greatest_fixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<nu>") where
  "\<nu> f \<equiv> THE x. is_gfp x f"

notation greatest_fixpoint (binder "\<nu>" 10)

lemma gfp_eta: "(\<nu> x. f x) = \<nu> f" by simp

lemma gfp_equality: "is_gfp x f \<Longrightarrow> \<nu> f = x"
  by (metis (lifting) eq_iff greatest_fixpoint_def is_gfp_def the_equality)

lemma gpp_is_gfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_gpp x f \<Longrightarrow> is_gfp x f"
  by (auto intro: antisym simp add: is_gfp_def is_gpp_def)

end

lemma continuity_mono:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(\<And>X. Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis Sup_le_iff antisym atMost_iff imageI order_refl)

lemma Inf_continuity_mono:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis antisym atLeast_iff image_eqI le_Inf_iff order_refl)

definition (in order) directed :: "'a set \<Rightarrow> bool" where
  "directed X \<equiv> X \<noteq> {} \<and> (\<forall>x y. x \<in> X \<and> y \<in> X \<longrightarrow> (\<exists>z. x \<le> z \<and> y \<le> z))"

context complete_lattice
begin

lemma continuity_mono1: "(\<And>X. Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis Sup_le_iff antisym atMost_iff imageI order_refl)

lemma continuity_mono2: "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis (full_types) Inf_atLeastAtMost Inf_superset_mono atLeastatMost_subset_iff eq_refl image_mono)

lemma scott_continuity_mono: "(\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
proof -
  assume scott_continuity: "\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X)"

  {
    fix x y
    have "directed {x, y}"
    by (auto intro: exI[of _ "sup x y"] simp add: directed_def)
    hence "Sup (f ` {x, y}) = f (Sup {x, y})"
      by (metis scott_continuity)
    hence "sup (f x) (f y) = f (sup x y)"
      by auto
  }
  moreover assume "x \<le> y"
  ultimately show ?thesis
    by (metis le_iff_sup)
qed

lemma Inf_continuity_mono1: "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis antisym atLeast_iff image_eqI le_Inf_iff order_refl)

theorem knaster_tarski_lpp:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" shows "\<exists>!x. is_lpp x f"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "Inf ?H"

  have "f ?a \<le> ?a"
  proof -
    have "\<forall>x\<in>?H. ?a \<le> x"
      by (auto intro: Inf_lower)
    hence "\<forall>x\<in>?H. f ?a \<le> f x"
      by (metis assms)
    hence "\<forall>x\<in>?H. f ?a \<le> x"
      by (metis (lifting) mem_Collect_eq order_trans)
    thus "f ?a \<le> ?a"
      by (metis Inf_greatest lfp_def)
  qed
  moreover show "\<And>x. is_lpp x f \<Longrightarrow> x = ?a"
    by (metis eq_iff is_lpp_def lfp_def lfp_greatest lfp_lowerbound)
  ultimately show "is_lpp ?a f"
    by (metis is_lpp_def lfp_def lfp_lowerbound)
qed

theorem knaster_tarski: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> \<exists>!x. is_lfp x f"
  by (metis knaster_tarski_lpp lfp_equality lpp_is_lfp)

corollary is_lfp_lfp [intro?]:
  "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_lfp (\<mu> f) f"
  by (metis knaster_tarski_lpp lfp_equality lpp_is_lfp)

theorem knaster_tarski_gpp:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" shows "\<exists>!x. is_gpp x f"
proof
  let ?H = "{u. u \<le> f u}"
  let ?a = "Sup ?H"

  have "?a \<le> f ?a"
  proof -
    have "\<forall>x\<in>?H. x \<le> ?a"
      by (metis Sup_upper)
    hence "\<forall>x\<in>?H. f x \<le> f ?a"
      by (metis assms)
    hence "\<forall>x\<in>?H. x \<le> f ?a"
      by (metis (lifting) mem_Collect_eq order_trans)
    thus "?a \<le> f ?a"
      by (metis Sup_least gfp_def)
  qed
  moreover show "\<And>x. is_gpp x f \<Longrightarrow> x = ?a"
    by (metis (lifting, full_types) Sup_upper calculation eq_iff is_gpp_def mem_Collect_eq)
  ultimately show "is_gpp ?a f"
    by (simp add: is_gpp_def) (metis (full_types) Sup_upper mem_Collect_eq)
qed

theorem knaster_tarski_gfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> \<exists>!x. is_gfp x f"
  by (metis gfp_equality gpp_is_gfp knaster_tarski_gpp)

corollary is_gfp_gfp [intro?]:
  "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_gfp (\<nu> f) f"
  by (metis gfp_equality knaster_tarski_gfp)

lemma fp_compute [simp]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f (\<mu> f) = \<mu> f"
  by (metis is_lfp_def is_lfp_lfp)

lemma gfp_compute [simp]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f (\<nu> f) = \<nu> f"
  by (metis is_gfp_def is_gfp_gfp)

lemma fp_induct [intro?]:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" and "f x \<le> x" shows "\<mu> f \<le> x"
  by (metis (full_types) assms is_lpp_def knaster_tarski_lpp lfp_equality lpp_is_lfp)

lemma gfp_induct [intro?]:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" and "x \<le> f x" shows "x \<le> \<nu> f"
  by (metis assms gpp_is_gfp is_gfp_gfp is_gpp_def knaster_tarski_gfp knaster_tarski_gpp)

primrec iter :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
  "iter f 0 x = x"
| "iter f (Suc n) x = f (iter f n x)"

lemma iter_mono: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> x \<le> y \<Longrightarrow> iter f n x \<le> iter f n y"
  by (induct n) simp_all

lemma iter_pp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f y \<le> y \<Longrightarrow> iter f n y \<le> y"
  apply (induct n)
  apply simp
  by (metis (full_types) iter.simps(2) order_trans)

lemma iter_plus: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> iter f n bot \<le> iter f (n + m) bot"
proof (induct n)
  case 0 thus ?case
    by auto
next
  case (Suc n)
  thus ?case
    by auto
qed

theorem kleene_lfp:
  assumes scott_continuity: "(\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X))"
  shows "\<mu> f = Sup {iter f n bot|n. True}"
proof -
  let ?C = "{iter f n bot|n. True}"
  let ?c = "Sup {iter f n bot|n. True}"

  have directed_C: "directed ?C"
    apply (auto simp add: directed_def)
    apply (rename_tac n m)
    apply (rule_tac x = "iter f (n + m) bot" in exI)
    apply auto
    apply (metis iter_plus scott_continuity scott_continuity_mono)
    by (metis (full_types) iter_plus nat_add_commute scott_continuity scott_continuity_mono)

  have "f ?c \<le> ?c"
  proof -
    have "f ?c = Sup (f ` ?C)"
      by (metis scott_continuity[OF directed_C])
    also have "... \<le> ?c"
      apply (rule Sup_mono)
      apply (auto simp add: image_def)
      apply (rule_tac x = "iter f (Suc n) bot" in exI)
      apply auto
      by (metis iter.simps(2))
    finally show ?thesis .
  qed

  moreover have "(\<forall>y. f y \<le> y \<longrightarrow> ?c \<le> y)"
  proof clarify
    fix y assume y_fp: "f y \<le> y"
    have "bot \<le> y"
      by (metis bot_least)
    hence "\<forall>n. iter f n bot \<le> iter f n y"
      by (metis scott_continuity scott_continuity_mono iter_mono)
     hence "\<forall>n. iter f n bot \<le> y"
      by (metis scott_continuity scott_continuity_mono iter_pp order_trans y_fp)
    thus "?c \<le> y"
      by (auto intro!: Sup_least)
  qed

  ultimately have "is_lpp ?c f"
    by (auto simp add: is_lpp_def)
  hence "is_lfp ?c f"
    by (metis (full_types) scott_continuity scott_continuity_mono lpp_is_lfp)
  thus "\<mu> f = ?c"
    by (metis lfp_equality)
qed

lemma kleene_gfp:
  assumes continuity: "(\<And>X. Inf (f ` X) = f (Inf X))"
  shows "\<nu> f = Inf {iter f n top|n. True}"
proof -
  let ?C = "{iter f n top|n. True}"
  let ?c = "Inf {iter f n top|n. True}"

  have "?c \<le> f ?c"
  proof -
    have "?c \<le> Inf (f ` ?C)"
      apply (rule Inf_mono)
      apply (auto simp add: image_def)
      apply (rule_tac x = "iter f (Suc n) top" in exI)
      apply auto
      by (metis iter.simps(2))
    also have "... \<le> f ?c"
      by (metis continuity eq_refl)
    finally show ?thesis .
  qed

  moreover have "(\<forall>y. y \<le> f y \<longrightarrow> y \<le> ?c)"
  proof clarify
    fix y assume y_fp: "y \<le> f y"
    have "y \<le> top"
     by (metis top_greatest)
    hence "\<forall>n. iter f n y \<le> iter f n top"
      by (metis continuity Inf_continuity_mono1 iter_mono)
    moreover have "\<forall>n. y \<le> iter f n y"
    proof clarify
      fix n show "y \<le> iter f n y" apply (induct n) apply simp_all
        apply (rule order_trans[of _ "f y"])
        apply (metis y_fp)
        apply (rule Inf_continuity_mono1[OF continuity])
        by auto
    qed
    ultimately have "\<forall>n. y \<le> iter f n top"
      by (metis order_trans)
    thus "y \<le> ?c"
      by (auto intro!: Inf_greatest)
  qed

  ultimately have "is_gpp ?c f"
    by (auto simp add: is_gpp_def)
  hence "is_gfp ?c f"
    by (metis (full_types) Inf_continuity_mono1 continuity gpp_is_gfp)
  thus "\<nu> f = ?c"
    by (metis gfp_equality)
qed

lemma gfp_equality_var [intro?]: "\<lbrakk>f x = x; \<And>y. f y = y \<Longrightarrow> y \<le> x\<rbrakk> \<Longrightarrow> x = \<nu> f"
  by (metis gfp_equality is_gfp_def)

lemma lfp_equality_var [intro?]: "\<lbrakk>f x = x; \<And>y. f y = y \<Longrightarrow> x \<le> y\<rbrakk> \<Longrightarrow> x = \<mu> f"
  by (metis is_lfp_def lfp_equality)

theorem endo_fixpoint_fusion [simp]:
  assumes upper_ex: "endo_lower_adjoint f"
  and hiso: "isotone h" and kiso: "isotone k"
  and comm: "f\<circ>h = k\<circ>f"
  shows "f (\<mu> h) = \<mu> k"
proof
  show "k (f (\<mu> h)) = f (\<mu> h)"
    by (metis comm fp_compute hiso isotone_def o_eq_dest_lhs)
next
  fix y assume ky: "k y = y"
  obtain g where conn: "endo_galois_connection f g" by (metis endo_lower_adjoint_def upper_ex)
  have "\<mu> h \<le> g y" using isotoneD[OF hiso]
  proof (rule fp_induct)
    have "f (g y) \<le> y" by (metis conn endo_deflation)
    hence "f (h (g y)) \<le> y" by (metis comm kiso ky isotoneD o_def)
    thus "h (g y) \<le> g y" by (metis conn endo_galois_connection_def)
  qed
  thus "f (\<mu> h) \<le> y" by (metis conn endo_galois_connection_def)
qed

theorem endo_greatest_fixpoint_fusion [simp]:
  assumes lower_ex: "endo_upper_adjoint g"
  and hiso: "isotone h" and kiso: "isotone k"
  and comm: "g\<circ>h = k\<circ>g"
  shows "g (\<nu> h) = \<nu> k"
proof
  show "k (g (\<nu> h)) = g (\<nu> h)"
    by (metis comm gfp_compute hiso isotone_def o_eq_dest_lhs)
next
  fix y assume ky: "k y = y"
  obtain f where conn: "endo_galois_connection f g" by (metis lower_ex endo_upper_adjoint_def)
  have "f y \<le> \<nu> h" using isotoneD[OF hiso]
  proof (rule gfp_induct)
    have "y \<le> g (f y)" by (metis conn endo_inflation)
    hence "y \<le> g (h (f y))" by (metis (full_types) comm comp_apply isotoneD kiso ky)
    thus "f y \<le> h (f y)" by (metis conn endo_galois_connection_def)
  qed
  thus "y \<le> g (\<nu> h)" by (metis conn endo_galois_connection_def)
qed

end

theorem fixpoint_fusion [simp]:
  fixes k :: "'b::complete_lattice \<Rightarrow> 'b"
  and h :: "'a::complete_lattice \<Rightarrow> 'a"
  and f :: "'a \<Rightarrow> 'b"
  assumes upper_ex: "lower_adjoint f"
  and hiso: "mono h" and kiso: "mono k"
  and comm: "f\<circ>h = k\<circ>f"
  shows "f (\<mu> h) = \<mu> k"
proof
  show "k (f (\<mu> h)) = f (\<mu> h)" using monoD[OF hiso]
    by (metis comm fp_compute o_eq_dest_lhs)
next
  fix y :: "'b" assume ky: "k y = y"
  obtain g where conn: "galois_connection f g" by (metis lower_adjoint_def upper_ex)
  have "\<mu> h \<le> g y"
  proof (rule fp_induct)
    fix x y :: 'a assume "x \<le> y" thus "h x \<le> h y"
      by (rule monoD[OF hiso])
  next
    have "f (g y) \<le> y" by (metis conn deflation)
    hence "f (h (g y)) \<le> y" by (metis comm kiso ky monoD o_def)
    thus "h (g y) \<le> g y" by (metis conn galois_connection_def)
  qed
  thus "f (\<mu> h) \<le> y" by (metis conn galois_connection_def)
qed

theorem greatest_fixpoint_fusion [simp]:
  fixes k :: "'b::complete_lattice \<Rightarrow> 'b"
  and h :: "'a::complete_lattice \<Rightarrow> 'a"
  and f :: "'a \<Rightarrow> 'b"
  assumes lower_ex: "upper_adjoint g"
  and hiso: "mono h" and kiso: "mono k"
  and comm: "g\<circ>h = k\<circ>g"
  shows "g (\<nu> h) = \<nu> k"
proof
  show "k (g (\<nu> h)) = g (\<nu> h)" using monoD[OF hiso]
    by (metis (full_types) comm comp_apply gfp_compute)
next
  fix y assume ky: "k y = y"
  obtain f where conn: "galois_connection f g" by (metis lower_ex upper_adjoint_def)
  have "f y \<le> \<nu> h"
  proof (rule gfp_induct)
    fix x y :: 'a assume "x \<le> y" thus "h x \<le> h y"
      by (rule monoD[OF hiso])
  next
    have "y \<le> g (f y)" by (metis conn inflation)
    hence "y \<le> g (h (f y))" by (metis (full_types) comm comp_apply monoD kiso ky)
    thus "f y \<le> h (f y)" by (metis conn galois_connection_def)
  qed
  thus "y \<le> g (\<nu> h)" by (metis conn galois_connection_def)
qed

definition join_preserving :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> bool" where
  "join_preserving f \<equiv> \<forall>X. Sup (f ` X) = f (Sup X)"

definition meet_preserving :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> bool" where
  "meet_preserving g \<equiv> \<forall>X. Inf (g ` X) = g (Inf X)"

(* +------------------------------------------------------------------------+
   | Theorems 4.25(a) and 4.25(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma (in complete_lattice) Sup_eq_equiv: "Sup A = x \<longleftrightarrow> (\<forall>z. (x \<le> z \<longleftrightarrow> (\<forall>y\<in>A. y \<le> z)))"
  apply default
  apply (metis Sup_le_iff)
  by (metis (full_types) Sup_le_iff Sup_upper le_iff_inf less_infI2 less_le order_refl)

lemma (in complete_lattice) Inf_eq_equiv: "Inf A = x \<longleftrightarrow> (\<forall>z. (z \<le> x \<longleftrightarrow> (\<forall>y\<in>A. z \<le> y)))"
  apply default
  apply (metis Inf_greatest Inf_lower order_trans)
  by (metis Inf_atLeast Inf_lower Inf_superset_mono atLeast_def mem_Collect_eq order.antisym subsetI)

lemma lower_adjoint_Sup:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  assumes "Sup X = x" and "lower_adjoint f" shows "Sup (f ` X) = f x" using assms
  apply (simp add: Sup_eq_equiv lower_adjoint_def)
  apply (erule exE)
  apply (simp add: galois_ump2 mono_def)
  apply (erule conjE)+
  by (metis order_trans)

lemma lower_preserves_join: "lower_adjoint f \<Longrightarrow> join_preserving f"
  by (metis join_preserving_def lower_adjoint_Sup)

theorem suprema_galois: "galois_connection f g = (join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y))"
proof (intro iffI conjI)
  assume "galois_connection f g"
  hence "lower_adjoint f"
    by (metis lower_adjoint_def)
  thus "join_preserving f"
    by (rule lower_preserves_join)
  from `galois_connection f g`
  show "\<forall>y. Sup {x. f x \<le> y} = g y"
    by (simp add: Sup_eq_equiv galois_ump2 mono_def) (metis (full_types) order_trans)
next
  assume "join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)"
  hence f_jp: "join_preserving f" and a2: "\<And>y. Sup {x. f x \<le> y} = g y"
    by auto
  have f_iso: "mono f"
    apply (rule monoI)
    apply (rule continuity_mono) back
    apply (metis f_jp join_preserving_def)
    by simp
  show "galois_connection f g"
  proof (simp add: galois_connection_def)
    have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
      using a2 by (auto simp only: Sup_eq_equiv)
    moreover have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
    proof (intro impI allI)
      fix x y
      assume gr: "x \<le> g y"
      show "f x \<le> y"
      proof -
        have lem: "Sup (f ` {x. f x \<le> y}) \<le> y"
          by (rule Sup_least) auto

        have "f x \<le> y \<Longrightarrow> x \<le> Sup {z. f z \<le> y}"
          by (metis `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
        moreover have "x \<le> Sup {z. f z \<le> y} \<Longrightarrow> f x \<le> f (Sup {z. f z \<le> y})"
          by (metis f_iso monoD)
        moreover have "(f x \<le> f (Sup {z. f z \<le> y})) = (f x \<le> Sup (f ` {z. f z \<le> y}))"
          by (metis (full_types) `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` join_preserving_def)
        moreover have "... \<Longrightarrow> f x \<le> y" using lem
          by (metis order_trans)
        ultimately show ?thesis
          by (metis `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

lemma lower_is_jp: "lower_adjoint f \<longleftrightarrow> join_preserving f"
proof
  assume "lower_adjoint f" thus "join_preserving f"
    by (metis lower_preserves_join)
next
  assume "join_preserving f"
  moreover hence "\<exists>g. \<forall>y. Sup {x. f x \<le> y} = g y"
    by auto
  ultimately show "lower_adjoint f"
    by (metis (full_types) lower_adjoint_def suprema_galois)
qed

context complete_lattice begin

definition endo_join_preserving :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_join_preserving f \<equiv> \<forall>X. Sup (f ` X) = f (Sup X)"

definition endo_meet_preserving :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_meet_preserving g \<equiv> \<forall>X. Inf (g ` X) = g (Inf X)"

(* +------------------------------------------------------------------------+
   | Theorems 4.25(a) and 4.25(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma endo_lower_adjoint_Sup: "Sup X = x \<Longrightarrow> endo_lower_adjoint f \<Longrightarrow> Sup (f ` X) = f x"
  apply (simp add: Sup_eq_equiv endo_lower_adjoint_def)
  apply (erule exE)
  apply (simp add: endo_galois_ump2 isotone_def)
  apply (erule conjE)+
  by (metis order_trans)

lemma endo_lower_preserves_join: "endo_lower_adjoint f \<Longrightarrow> endo_join_preserving f"
  by (metis endo_join_preserving_def endo_lower_adjoint_Sup)

theorem endo_suprema_galois: "endo_galois_connection f g = (endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y))"
proof (intro iffI conjI)
  assume "endo_galois_connection f g"
  hence "endo_lower_adjoint f"
    by (metis endo_lower_adjoint_def)
  thus "endo_join_preserving f"
    by (rule endo_lower_preserves_join)
  from `endo_galois_connection f g`
  show "\<forall>y. Sup {x. f x \<le> y} = g y"
    by (simp add: Sup_eq_equiv endo_galois_ump2 isotone_def) (metis (full_types) order_trans)
next
  assume "endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)"
  hence f_jp: "endo_join_preserving f" and a2: "\<And>y. Sup {x. f x \<le> y} = g y"
    by auto
  hence f_iso: "isotone f"
    by (metis (mono_tags) continuity_mono1 endo_join_preserving_def isotone_def)
  show "endo_galois_connection f g"
  proof (simp add: endo_galois_connection_def)
    have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
      using a2 by (auto simp only: Sup_eq_equiv)
    moreover have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
    proof (intro impI allI)
      fix x y
      assume gr: "x \<le> g y"
      show "f x \<le> y"
      proof -
        have lem: "Sup (f ` {x. f x \<le> y}) \<le> y"
          by (metis (full_types) SUP_def SUP_le_iff mem_Collect_eq)

        have "f x \<le> y \<Longrightarrow> x \<le> Sup {z. f z \<le> y}"
          by (metis `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
        moreover have "x \<le> Sup {z. f z \<le> y} \<Longrightarrow> f x \<le> f (Sup {z. f z \<le> y})"
          by (metis f_iso isotoneD)
        moreover have "(f x \<le> f (Sup {z. f z \<le> y})) = (f x \<le> Sup (f ` {z. f z \<le> y}))"
          by (metis (full_types) `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` endo_join_preserving_def)
        moreover have "... \<Longrightarrow> f x \<le> y" using lem
          by (metis order_trans)
        ultimately show ?thesis
          by (metis `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

lemma endo_lower_is_jp: "endo_lower_adjoint f \<longleftrightarrow> endo_join_preserving f"
proof
  assume "endo_lower_adjoint f" thus "endo_join_preserving f"
    by (metis endo_lower_preserves_join)
next
  assume "endo_join_preserving f"
  moreover hence "\<exists>g. \<forall>y. Sup {x. f x \<le> y} = g y"
    by auto
  ultimately show "endo_lower_adjoint f"
    by (metis (full_types) endo_lower_adjoint_def endo_suprema_galois)
qed

lemma endo_upper_adjoint_Inf: "Inf X = x \<Longrightarrow> endo_upper_adjoint f \<Longrightarrow> Inf (f ` X) = f x"
  apply (simp add: Inf_eq_equiv endo_upper_adjoint_def)
  apply (erule exE)
  apply (simp add: endo_galois_ump2 isotone_def)
  apply (erule conjE)+
  by (metis order_trans)

lemma endo_upper_preserves_meet: "endo_upper_adjoint f \<Longrightarrow> endo_meet_preserving f"
  by (metis endo_meet_preserving_def endo_upper_adjoint_Inf)

theorem endo_infima_galois: "endo_galois_connection f g = (endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y))"
proof (intro iffI conjI)
  assume "endo_galois_connection f g"
  hence "endo_upper_adjoint g"
    by (metis endo_upper_adjoint_def)
  thus "endo_meet_preserving g"
    by (rule endo_upper_preserves_meet)
  from `endo_galois_connection f g`
  show "\<forall>y. Inf {x. y \<le> g x} = f y"
    by (simp add: Inf_eq_equiv endo_galois_ump1 isotone_def) (metis (full_types) order_trans)
next
  assume "endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y)"
  hence f_jp: "endo_meet_preserving g" and a2: "\<And>y. Inf {x. y \<le> g x} = f y"
    by auto
  hence f_iso: "isotone g"
    by (metis (mono_tags) continuity_mono2 endo_meet_preserving_def isotone_def)
  show "endo_galois_connection f g"
  proof (simp add: endo_galois_connection_def)
    have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
      using a2 by (metis Inf_lower mem_Collect_eq)
    moreover have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
    proof (intro impI allI)
      fix x y
      assume gr: "f x \<le> y"
      thus "x \<le> g y"
      proof -
        have lem: "x \<le> Inf (g ` {y. x \<le> g y})"
          by (metis (full_types) INF_def INF_greatest mem_Collect_eq)

        also have "... \<le> g y"
          by (metis (mono_tags) `endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y)` endo_meet_preserving_def f_iso gr isotoneD)

        finally show ?thesis .
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

(* Dual theorem *)
lemma endo_upper_is_mp: "endo_upper_adjoint g \<longleftrightarrow> endo_meet_preserving g"
proof
  assume "endo_upper_adjoint g" thus "endo_meet_preserving g"
    by (metis endo_upper_preserves_meet)
next
  assume "endo_meet_preserving g"
  moreover hence "\<exists>f. \<forall>x. Inf {y. x \<le> g y} = f x"
    by auto
  ultimately show "endo_upper_adjoint g"
    by (metis endo_infima_galois endo_upper_adjoint_def)
qed

end

end


(*
    Title:      Projections.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Projections\<close>

theory Projections
imports
  Miscellaneous_QR
begin

subsection\<open>Definitions of vector projection and projection of a vector onto a set.\<close>

definition "proj v u = (v \<bullet> u / (u \<bullet> u)) *\<^sub>R u"

definition "proj_onto a S = (sum (\<lambda>x. proj a x) S)"

subsection\<open>Properties\<close>

lemma proj_onto_sum_rw:
  "sum (\<lambda>x. (x \<bullet> v / (x \<bullet> x)) *\<^sub>R x) A = sum (\<lambda>x. (v \<bullet> x / (x \<bullet> x)) *\<^sub>R x) A"
  by (rule sum.cong, auto simp add: inner_commute)

lemma vector_sub_project_orthogonal_proj:
  fixes b x :: "'a::euclidean_space"
  shows "inner b (x - proj x b) = 0"
  using vector_sub_project_orthogonal
  unfolding proj_def inner_commute[of x b]
  by auto

lemma orthogonal_proj_set:
  assumes yC: "y\<in>C" and C: "finite C" and p: "pairwise orthogonal C"
  shows "orthogonal (a - proj_onto a C) y"
proof -
  have Cy: "C = insert y (C - {y})" using yC
    by blast
  have fth: "finite (C - {y})"
    using C by simp
  show "orthogonal (a - proj_onto a C) y"
    unfolding orthogonal_def unfolding proj_onto_def unfolding proj_def[abs_def]
    unfolding inner_diff
    unfolding inner_sum_left
    unfolding right_minus_eq
    unfolding sum.remove[OF C yC]
    apply (clarsimp simp add: inner_commute[of y a])
    apply (rule sum.neutral)
    apply clarsimp
    apply (rule p[unfolded pairwise_def orthogonal_def, rule_format])
    using yC by auto
qed

lemma pairwise_orthogonal_proj_set:
  assumes C: "finite C" and p: "pairwise orthogonal C"
  shows "pairwise orthogonal (insert (a - proj_onto a C) C)"
  by (rule pairwise_orthogonal_insert[OF p], auto simp add: orthogonal_proj_set C p)

subsection\<open>Orthogonal Complement\<close>

definition "orthogonal_complement W = {x. \<forall>y \<in> W. orthogonal x y}"

lemma in_orthogonal_complement_imp_orthogonal:
  assumes x: "y \<in> S"
  and "x \<in> orthogonal_complement S"
  shows "orthogonal x y"
  using assms orthogonal_commute
  unfolding orthogonal_complement_def
  by blast

lemma subspace_orthogonal_complement: "subspace (orthogonal_complement W)"
  unfolding subspace_def orthogonal_complement_def
  by (simp add: orthogonal_def inner_left_distrib)

lemma orthogonal_complement_mono:
  assumes A_in_B: "A \<subseteq> B"
  shows "orthogonal_complement B \<subseteq> orthogonal_complement A"
proof
  fix x assume x: "x \<in> orthogonal_complement B"
  show "x \<in> orthogonal_complement A" using x unfolding orthogonal_complement_def
    by (simp add: orthogonal_def, metis A_in_B in_mono)
qed

lemma B_in_orthogonal_complement_of_orthogonal_complement:
  shows "B \<subseteq> orthogonal_complement (orthogonal_complement B)"
  by (auto simp add: orthogonal_complement_def orthogonal_def inner_commute)

lemma phytagorean_theorem_norm:
  assumes o: "orthogonal x y"
  shows "norm (x+y)^2=norm x^2 + norm y^2"
proof -
  have "norm (x+y)^2 = (x+y) \<bullet> (x+y)" unfolding power2_norm_eq_inner ..
  also have "... = ((x+y) \<bullet> x) + ((x+y) \<bullet> y)" unfolding inner_right_distrib ..
  also have "... = (x \<bullet> x) + (x \<bullet> y) + (y \<bullet> x) + (y \<bullet> y) "
    unfolding real_inner_class.inner_add_left by simp
  also have "... = (x \<bullet> x) + (y \<bullet> y)" using o unfolding orthogonal_def
    by (metis monoid_add_class.add.right_neutral inner_commute)
  also have "... = norm x^2 + norm y^2" unfolding power2_norm_eq_inner ..
  finally show ?thesis .
qed

lemma in_orthogonal_complement_basis:
  fixes B::"'a::{euclidean_space} set"
  assumes S: "subspace S"
  and ind_B: "independent B"
  and B: "B \<subseteq> S"
  and span_B: "S \<subseteq> span B"
  shows "(v \<in> orthogonal_complement S) = (\<forall>a\<in>B. orthogonal a v)"
proof (unfold orthogonal_complement_def, auto)
  fix a assume "\<forall>x\<in>S. orthogonal v x" and "a \<in> B"
  thus "orthogonal a v"
    by (metis B orthogonal_commute rev_subsetD)
next
  fix x assume o: "\<forall>a\<in>B. orthogonal a v" and x: "x \<in> S"
  have finite_B: "finite B" using independent_bound_general[OF ind_B] ..
  have span_B_eq: "S = span B" using B S span_B span_subspace by blast
  obtain f where f: "(\<Sum>a\<in>B. f a *\<^sub>R a) = x" using span_finite[OF finite_B]
    using x unfolding span_B_eq by force
  have "v \<bullet> x = v \<bullet> (\<Sum>a\<in>B. f a *\<^sub>R a)" unfolding f ..
  also have "... = (\<Sum>a\<in>B. v \<bullet> (f a *\<^sub>R a))" unfolding inner_sum_right ..
  also have "... = (\<Sum>a\<in>B. f a * (v \<bullet> a))" unfolding inner_scaleR_right ..
  also have "... = 0" using sum.neutral o by (simp add: orthogonal_def inner_commute)
  finally show "orthogonal v x" unfolding orthogonal_def .
qed

text\<open>See @{url "https://people.math.osu.edu/husen.1/teaching/571/least_squares.pdf"}\<close>

text\<open>Part 1 of the Theorem 1.7 in the previous website, but the proof has been carried out
  in other way.\<close>

lemma v_minus_p_orthogonal_complement:
  fixes X::"'a::{euclidean_space} set"
  assumes subspace_S: "subspace S"
  and ind_X: "independent X"
  and X: "X \<subseteq> S"
  and span_X: "S \<subseteq> span X"
  and o: "pairwise orthogonal X"
  shows "(v - proj_onto v X) \<in> orthogonal_complement S"
  unfolding in_orthogonal_complement_basis[OF subspace_S ind_X X span_X]
proof
  fix a assume a: "a \<in> X"
  let ?p="proj_onto v X"
  show "orthogonal a (v - ?p)"
    unfolding orthogonal_commute[of a "v-?p"]
    by (rule orthogonal_proj_set[OF a _ o])
       (simp add: independent_bound_general[OF ind_X])
qed

text\<open>Part 2 of the Theorem 1.7 in the previous website.\<close>

lemma UNIV_orthogonal_complement_decomposition:
  fixes S::"'a::{euclidean_space} set"
  assumes s: "subspace S"
  shows "UNIV = S + (orthogonal_complement S)"
proof (unfold set_plus_def, auto)
  fix v
  obtain X where ind_X: "independent X"
    and X: "X \<subseteq> S"
    and span_X: "S \<subseteq> span X"
    and o: "pairwise orthogonal X"
    by (metis order_refl orthonormal_basis_subspace s)
  have finite_X: "finite X" by (metis independent_bound_general ind_X)
  let ?p="proj_onto v X"
  have "v=?p +(v-?p)" by simp
  moreover have "?p \<in> S" unfolding proj_onto_def proj_def[abs_def]
    by (rule subspace_sum[OF s])
      (simp add: X s rev_subsetD subspace_mul)
  moreover have "(v-?p) \<in> orthogonal_complement S"
    by (rule v_minus_p_orthogonal_complement[OF s ind_X X span_X o])
  ultimately show "\<exists>a\<in>S. \<exists>b\<in>orthogonal_complement S. v = a + b" by force
qed

subsection\<open>Normalization of vectors\<close>

definition normalize
  where "normalize x  = ((1/norm x) *\<^sub>R x)"
definition normalize_set_of_vec
  where "normalize_set_of_vec X  = normalize` X"

lemma normalize_0: "(normalize x = 0) = (x = 0)"
  unfolding normalize_def by auto

lemma norm_normalize_set_of_vec:
  assumes "x \<noteq> 0"
  and "x \<in> normalize_set_of_vec X"
  shows "norm x = 1"
  using assms norm_normalize normalize_0 unfolding normalize_set_of_vec_def  by blast

end


(*
    File:      Liouville_Lambda.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>The Liouville $\lambda$ function\<close>
theory Liouville_Lambda
  imports
    "HOL-Computational_Algebra.Computational_Algebra"
    "HOL-Number_Theory.Number_Theory"
    Dirichlet_Series
    Multiplicative_Function
    Moebius_Mu
begin

definition liouville_lambda :: "nat \<Rightarrow> 'a :: comm_ring_1" where
  "liouville_lambda n = (if n = 0 then 0 else (-1) ^ size (prime_factorization n))"

interpretation liouville_lambda: completely_multiplicative_function' liouville_lambda "\<lambda>_. -1"
proof
  fix a b :: nat assume "a > 1" "b > 1"
  thus "liouville_lambda (a * b) = liouville_lambda a * liouville_lambda b"
    by (simp add: liouville_lambda_def prime_factorization_mult power_add)
qed (simp_all add: liouville_lambda_def prime_factorization_prime One_nat_def [symmetric]
              del: One_nat_def)

lemma liouville_lambda_prime [simp]: "prime p \<Longrightarrow> liouville_lambda p = -1"
  by (simp add: liouville_lambda_def prime_factorization_prime)

lemma liouville_lambda_prime_power [simp]: "prime p \<Longrightarrow> liouville_lambda (p ^ k) = (-1) ^ k"
  by (simp add: liouville_lambda_def prime_factorization_prime_power)

lemma liouville_lambda_squarefree: "squarefree n \<Longrightarrow> liouville_lambda n = moebius_mu n"
  by (auto simp: liouville_lambda_def moebius_mu_squarefree_eq' intro!: Nat.gr0I)

lemma power_neg_one_If: "(-1) ^ n = (if even n then 1 else -1 :: 'a :: ring_1)"
  by (induction n) (simp_all split: if_splits)

lemma liouville_lambda_power_even:
  "n > 0 \<Longrightarrow> even m \<Longrightarrow> liouville_lambda (n ^ m) = 1"
  by (subst liouville_lambda.power) (auto elim!: evenE simp: liouville_lambda_def power_neg_one_If)

lemma liouville_lambda_power_odd:
  "odd m \<Longrightarrow> liouville_lambda (n ^ m) = liouville_lambda n"
  by (subst liouville_lambda.power) (auto elim!: oddE simp: liouville_lambda_def power_neg_one_If)

lemma liouville_lambda_power:
  "liouville_lambda (n ^ m) =
     (if n = 0 \<and> m > 0 then 0 else if even m then 1 else liouville_lambda n)"
  by (auto simp: liouville_lambda_power_even liouville_lambda_power_odd power_0_left)

interpretation squarefree: multiplicative_function'
  "ind squarefree" "\<lambda>p k. if k > 1 then 0 else 1" "\<lambda>_. 1"
proof
  fix p k :: nat assume "prime p" "k > 0"
  thus "ind squarefree (p ^ k) = (if 1 < k then 0 else 1 :: 'a)"
    by (cases "k = 1") (auto simp: squarefree_power_iff squarefree_prime ind_def)
qed (auto simp: squarefree_mult_coprime squarefree_power_iff ind_def dest: squarefree_multD
          simp del: One_nat_def)

interpretation is_nth_power: multiplicative_function "ind (is_nth_power n)"
  by standard (auto simp: is_nth_power_mult_coprime_nat_iff)

interpretation is_nth_power: multiplicative_function'
  "ind (is_nth_power n)" "\<lambda>p k. if n dvd k then 1 else 0" "\<lambda>_. if n = 1 then 1 else 0"
  by standard (simp_all add: is_nth_power_prime_power_nat_iff ind_def)

interpretation is_square: multiplicative_function "ind is_square"
  by standard (auto simp: is_nth_power_mult_coprime_nat_iff)

interpretation is_square: multiplicative_function'
  "ind is_square" "\<lambda>p k. if even k then 1 else 0" "\<lambda>_. 0"
  by standard (simp_all add: is_nth_power_prime_power_nat_iff ind_def)

lemma liouville_lambda_divisors_sum:
  "(\<Sum>d | d dvd n. liouville_lambda d) = ind is_square n"
proof (rule multiplicative_function_eqI)
  show "multiplicative_function (\<lambda>n. (\<Sum>d | d dvd n. liouville_lambda d))"
    by (rule liouville_lambda.multiplicative_sum_divisors)
  show "multiplicative_function (ind is_square)"
    by (rule is_nth_power.multiplicative_function_axioms)
next
  fix p k :: nat assume pk: "prime p" "k > 0"
  hence p_gt_1: "p > 1" by (simp add: prime_gt_Suc_0_nat)
  have "(\<Sum>d | d dvd p ^ k. liouville_lambda d) = (\<Sum>d\<in>(\<lambda>i. p ^ i) ` {..k}. liouville_lambda d)"
    using pk by (intro sum.cong refl) (auto intro: le_imp_power_dvd simp: divides_primepow_nat)
  also from pk and p_gt_1 have "\<dots> = (\<Sum>i\<le>k. liouville_lambda (p ^ i))"
    by (subst sum.reindex) (auto simp: inj_on_def prime_gt_1_nat)
  also from pk have "\<dots> = (\<Sum>i\<le>k. (-1) ^ i)" by (intro sum.cong refl) simp
  also have "\<dots> = (if even k then 1 else 0)" by (induction k) auto
  also from pk have "\<dots> = ind is_square (p ^ k)" by (simp add: is_square.prime_power)
  finally show "(\<Sum>d | d dvd p ^ k. liouville_lambda d) = ind is_square (p ^ k)" .
qed

lemma fds_liouville_lambda_times_zeta: "fds liouville_lambda * fds_zeta = fds_ind is_square"
  by (rule fds_eqI) (simp add: liouville_lambda_divisors_sum fds_nth_mult dirichlet_prod_def)

lemma fds_liouville_lambda: "fds liouville_lambda = fds_ind is_square * fds moebius_mu"
proof -
  have "fds liouville_lambda * fds_zeta * fds moebius_mu = fds_ind is_square * fds moebius_mu"
    by (simp add: fds_liouville_lambda_times_zeta)
  also have "fds liouville_lambda * fds_zeta * fds moebius_mu = fds liouville_lambda"
    by (simp only: mult.assoc fds_zeta_times_moebius_mu mult_1_right)
  finally show ?thesis .
qed

lemma liouville_lambda_altdef:
  "liouville_lambda n = (\<Sum>d | d ^ 2 dvd n. moebius_mu (n div d ^ 2))"
proof (cases "n = 0")
  case False
  have "liouville_lambda n = fds_nth (fds liouville_lambda) n" by (simp add: fds_nth_fds)
  also have "fds liouville_lambda = fds_ind is_square * (fds moebius_mu :: 'a fds)"
    by (rule fds_liouville_lambda)
  also have "fds_nth \<dots> n = (\<Sum>d | d dvd n. ind is_square d * moebius_mu (n div d))"
    by (simp add: fds_nth_mult dirichlet_prod_def)
  also have "\<dots> = (\<Sum>d \<in> (\<lambda>d. d^2) ` {d. d ^ 2 dvd n}. moebius_mu (n div d))" using False
    by (intro sum.mono_neutral_cong_right) (auto simp: ind_def is_nth_power_def)
  also have "\<dots> = (\<Sum>d | d ^ 2 dvd n. moebius_mu (n div d ^ 2))"
    by (subst sum.reindex) (auto simp: inj_on_def dest: power2_eq_imp_eq)
  finally show ?thesis .
qed auto

lemma abs_moebius_mu: "abs (moebius_mu n :: 'a :: linordered_idom) = ind squarefree n"
  by (auto simp: ind_def moebius_mu_def)

end


section \<open>Ranks, $k$ smallest element and elements\<close>

theory K_Smallest
  imports
    Frequency_Moments_Preliminary_Results
    Interpolation_Polynomials_HOL_Algebra.Interpolation_Polynomial_Cardinalities
begin

text \<open>This section contains definitions and results for the selection of the $k$ smallest elements, the $k$-th smallest element, rank of an element in an ordered set.\<close>

definition rank_of :: "'a :: linorder \<Rightarrow> 'a set \<Rightarrow> nat" where "rank_of x S = card {y \<in> S. y < x}"
text \<open>The function @{term "rank_of"} returns the rank of an element within a set.\<close>

lemma rank_mono:
  assumes "finite S"
  shows "x \<le> y \<Longrightarrow> rank_of x S \<le> rank_of y S"
  unfolding rank_of_def using assms by (intro card_mono, auto)

lemma rank_mono_2:
  assumes "finite S"
  shows "S' \<subseteq> S \<Longrightarrow> rank_of x S' \<le> rank_of x S"
  unfolding rank_of_def using assms by (intro card_mono, auto)

lemma rank_mono_commute:
  assumes "finite S"
  assumes "S \<subseteq> T"
  assumes "strict_mono_on T f"
  assumes "x \<in> T"
  shows "rank_of x S = rank_of (f x) (f ` S)"
proof -
  have a: "inj_on f T"
    by (metis assms(3) strict_mono_on_imp_inj_on)

  have "rank_of (f x) (f ` S) = card (f ` {y \<in> S. f y < f x})"
    unfolding rank_of_def by (intro arg_cong[where f="card"], auto)
  also have "... = card (f ` {y \<in> S. y < x})"
    using assms by (intro arg_cong[where f="card"] arg_cong[where f="(`) f"])
     (meson in_mono linorder_not_le strict_mono_onD strict_mono_on_leD set_eq_iff)
  also have "... = card {y \<in> S. y < x}"
    using assms by (intro card_image  inj_on_subset[OF a], blast)
  also have "... = rank_of x S"
    by (simp add:rank_of_def)
  finally show ?thesis
    by simp
qed

definition least where "least k S = {y \<in> S. rank_of y S < k}"
text \<open>The function @{term "least"} returns the k smallest elements of a finite set.\<close>

lemma rank_strict_mono:
  assumes "finite S"
  shows "strict_mono_on S (\<lambda>x. rank_of x S)"
proof -
  have "\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x < y \<Longrightarrow> rank_of x S < rank_of y S"
    unfolding rank_of_def using assms
    by (intro psubset_card_mono, auto)

  thus ?thesis
    by (simp add:rank_of_def strict_mono_on_def)
qed

lemma rank_of_image:
  assumes "finite S"
  shows "(\<lambda>x. rank_of x S) ` S = {0..<card S}"
proof (rule card_seteq)
  show "finite {0..<card S}" by simp

  have "\<And>x. x \<in> S \<Longrightarrow> card {y \<in> S. y < x} < card S"
    by (rule psubset_card_mono, metis assms, blast)
  thus "(\<lambda>x. rank_of x S) ` S \<subseteq> {0..<card S}"
    by (intro image_subsetI, simp add:rank_of_def)

  have "inj_on (\<lambda>x. rank_of x S) S"
    by (metis strict_mono_on_imp_inj_on rank_strict_mono assms)
  thus "card {0..<card S} \<le> card ((\<lambda>x. rank_of x S) ` S)"
    by (simp add:card_image)
qed

lemma card_least:
  assumes "finite S"
  shows "card (least k S) = min k (card S)"
proof (cases "card S < k")
  case True
  have "\<And>t. rank_of t S \<le> card S"
    unfolding rank_of_def using assms
    by (intro card_mono, auto)
  hence "\<And>t. rank_of t S < k"
    by (metis True not_less_iff_gr_or_eq order_less_le_trans)
  hence "least k S = S"
    by (simp add:least_def)
  then show ?thesis using True by simp
next
  case False
  hence a:"card S \<ge> k" using leI by blast
  hence "card ((\<lambda>x. rank_of x S) -` {0..<k} \<inter> S) = card {0..<k}"
    using assms
    by (intro card_vimage_inj_on strict_mono_on_imp_inj_on rank_strict_mono)
     (simp_all add: rank_of_image)
  hence "card (least k S) = k"
    by (simp add: Collect_conj_eq Int_commute least_def vimage_def)
  then show ?thesis using a by linarith
qed

lemma least_subset: "least k S \<subseteq> S"
  by (simp add:least_def)

lemma least_mono_commute:
  assumes "finite S"
  assumes "strict_mono_on S f"
  shows "f ` least k S = least k (f ` S)"
proof -
  have a:"inj_on f S"
    using strict_mono_on_imp_inj_on[OF assms(2)] by simp

  have "card (least k (f ` S)) = min k (card (f ` S))"
    by (subst card_least, auto simp add:assms)
  also have "... = min k (card S)"
    by (subst card_image, metis a, auto)
  also have "... = card (least k S)"
    by (subst card_least, auto simp add:assms)
  also have "... = card (f ` least k S)"
    by (subst card_image[OF inj_on_subset[OF a]], simp_all add:least_def)
  finally have b: "card (least k (f ` S)) \<le> card (f ` least k S)" by simp

  have c: "f ` least k S \<subseteq>least k (f ` S)"
    using assms by (intro image_subsetI)
      (simp add:least_def rank_mono_commute[symmetric, where T="S"])

  show ?thesis
    using b c assms by (intro card_seteq, simp_all add:least_def)
qed

lemma least_eq_iff:
  assumes "finite B"
  assumes "A \<subseteq> B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> rank_of x B < k \<Longrightarrow> x \<in> A"
  shows "least k A = least k B"
proof -
  have "least k B \<subseteq> least k A"
    using assms rank_mono_2[OF assms(1,2)] order_le_less_trans
    by (simp add:least_def, blast)
  moreover have "card (least k B) \<ge> card (least k A)"
    using assms finite_subset[OF assms(2,1)] card_mono[OF assms(1,2)]
    by (simp add: card_least min_le_iff_disj)
  moreover have "finite (least k A)"
    using finite_subset least_subset assms(1,2) by metis
  ultimately show ?thesis
    by (intro card_seteq[symmetric], simp_all)
qed

lemma least_insert:
  assumes "finite S"
  shows "least k (insert x (least k S)) = least k (insert x S)" (is "?lhs = ?rhs")
proof (rule least_eq_iff)
  show "finite (insert x S)"
    using assms(1) by simp
  show "insert x (least k S) \<subseteq> insert x S"
    using least_subset by blast
  show "y \<in> insert x (least k S)" if a: "y \<in> insert x S" and b: "rank_of y (insert x S) < k" for y
  proof -
    have "rank_of y S \<le> rank_of y (insert x S)"
      using assms by (intro rank_mono_2, auto)
    also have "... < k" using b by simp
    finally have "rank_of y S < k" by simp
    hence "y = x \<or> (y \<in> S \<and> rank_of y S < k)"
      using a by simp
    thus ?thesis by (simp add:least_def)
  qed
qed

definition count_le where "count_le x M = size {#y \<in># M. y \<le> x#}"
definition count_less where "count_less x M = size {#y \<in># M. y < x#}"

definition nth_mset :: "nat \<Rightarrow> ('a :: linorder) multiset \<Rightarrow> 'a" where
  "nth_mset k M = sorted_list_of_multiset M ! k"

lemma nth_mset_bound_left:
  assumes "k < size M"
  assumes "count_less x M \<le> k"
  shows "x \<le> nth_mset k M"
proof (rule ccontr)
  define xs where "xs = sorted_list_of_multiset M"
  have s_xs: "sorted xs" by (simp add:xs_def sorted_sorted_list_of_multiset)
  have l_xs: "k < length xs"
    using  assms(1) by (simp add:xs_def size_mset[symmetric])
  have M_xs: "M = mset xs" by (simp add:xs_def)
  hence a:"\<And>i. i \<le> k \<Longrightarrow> xs ! i \<le> xs ! k"
    using s_xs l_xs sorted_iff_nth_mono by blast

  assume "\<not>(x \<le> nth_mset k M)"
  hence "x > nth_mset k M" by simp
  hence b:"x > xs ! k" by (simp add:nth_mset_def xs_def[symmetric])

  have "k < card {0..k}" by simp
  also have "... \<le> card {i. i < length xs \<and> xs ! i < x}"
    using a b l_xs order_le_less_trans
    by (intro card_mono subsetI) auto
  also have "... = length (filter (\<lambda>y. y < x) xs)"
    by (subst length_filter_conv_card, simp)
  also have "... = size (mset (filter (\<lambda>y. y < x) xs))"
    by (subst size_mset, simp)
  also have "... = count_less x M"
    by (simp add:count_less_def M_xs)
  also have "... \<le> k"
    using assms by simp
  finally show "False" by simp
qed

lemma nth_mset_bound_left_excl:
  assumes "k < size M"
  assumes "count_le x M \<le> k"
  shows "x < nth_mset k M"
proof (rule ccontr)
  define xs where "xs = sorted_list_of_multiset M"
  have s_xs: "sorted xs" by (simp add:xs_def sorted_sorted_list_of_multiset)
  have l_xs: "k < length xs"
    using  assms(1) by (simp add:xs_def size_mset[symmetric])
  have M_xs: "M = mset xs" by (simp add:xs_def)
  hence a:"\<And>i. i \<le> k \<Longrightarrow> xs ! i \<le> xs ! k"
    using s_xs l_xs sorted_iff_nth_mono by blast

  assume "\<not>(x < nth_mset k M)"
  hence "x \<ge> nth_mset k M" by simp
  hence b:"x \<ge> xs ! k" by (simp add:nth_mset_def xs_def[symmetric])

  have "k+1 \<le> card {0..k}" by simp
  also have "... \<le> card {i. i < length xs \<and> xs ! i \<le> xs ! k}"
    using a b l_xs order_le_less_trans
    by (intro card_mono subsetI, auto)
  also have "... \<le> card {i. i < length xs \<and> xs ! i \<le> x}"
    using b by (intro card_mono subsetI, auto)
  also have "... = length (filter (\<lambda>y. y \<le> x) xs)"
    by (subst length_filter_conv_card, simp)
  also have "... = size (mset (filter (\<lambda>y. y \<le> x) xs))"
    by (subst size_mset, simp)
  also have "... = count_le x M"
    by (simp add:count_le_def M_xs)
  also have "... \<le> k"
    using assms by simp
  finally show "False" by simp
qed

lemma nth_mset_bound_right:
  assumes "k < size M"
  assumes "count_le x M > k"
  shows "nth_mset k M \<le> x"
proof (rule ccontr)
  define xs where "xs = sorted_list_of_multiset M"
  have s_xs: "sorted xs" by (simp add:xs_def sorted_sorted_list_of_multiset)
  have l_xs: "k < length xs"
    using  assms(1) by (simp add:xs_def size_mset[symmetric])
  have M_xs: "M = mset xs" by (simp add:xs_def)

  assume "\<not>(nth_mset k M \<le> x)"
  hence "x < nth_mset k M" by simp
  hence "x < xs ! k"
    by (simp add:nth_mset_def xs_def[symmetric])
  hence a:"\<And>i. i < length xs \<and> xs ! i \<le> x \<Longrightarrow> i < k"
    using s_xs l_xs sorted_iff_nth_mono leI by fastforce
  have "count_le x M = size (mset (filter (\<lambda>y. y \<le> x) xs))"
    by (simp add:count_le_def M_xs)
  also have "... = length (filter (\<lambda>y. y \<le> x) xs)"
    by (subst size_mset, simp)
  also have "... = card {i. i < length xs \<and> xs ! i \<le> x}"
    by (subst length_filter_conv_card, simp)
  also have "... \<le> card {i. i < k}"
    using a by (intro card_mono subsetI, auto)
  also have "... = k" by simp
  finally have "count_le x M \<le> k" by simp
  thus "False" using assms by simp
qed

lemma nth_mset_commute_mono:
  assumes "mono f"
  assumes "k < size M"
  shows "f (nth_mset k M) = nth_mset k (image_mset f M)"
proof -
  have a:"k < length (sorted_list_of_multiset M)"
    by (metis assms(2) mset_sorted_list_of_multiset size_mset)
  show ?thesis
    using a by (simp add:nth_mset_def sorted_list_of_multiset_image_commute[OF assms(1)])
qed

lemma nth_mset_max:
  assumes "size A > k"
  assumes "\<And>x. x \<le> nth_mset k A \<Longrightarrow> count A x \<le> 1"
  shows "nth_mset k A = Max (least (k+1) (set_mset A))" and "card (least (k+1) (set_mset A)) = k+1"
proof -
  define xs where "xs = sorted_list_of_multiset A"
  have k_bound: "k < length xs" unfolding xs_def
    by (metis size_mset mset_sorted_list_of_multiset assms(1))

  have A_def: "A = mset xs" by (simp add:xs_def)
  have s_xs: "sorted xs" by (simp add:xs_def sorted_sorted_list_of_multiset)
  have "\<And>x. x \<le> xs ! k \<Longrightarrow> count A x \<le> Suc 0"
    using assms(2) by (simp add:xs_def[symmetric] nth_mset_def)
  hence no_col: "\<And>x. x \<le> xs ! k \<Longrightarrow> count_list xs x \<le> 1"
    by (simp add:A_def count_mset)

  have inj_xs: "inj_on (\<lambda>k. xs ! k) {0..k}"
    by (rule inj_onI, simp) (metis (full_types) count_list_ge_2_iff k_bound no_col
        le_neq_implies_less linorder_not_le order_le_less_trans s_xs sorted_iff_nth_mono)

  have "\<And>y. y < length xs \<Longrightarrow> rank_of (xs ! y) (set xs) < k+1 \<Longrightarrow> y < k+1"
  proof (rule ccontr)
    fix y
    assume b:"y < length xs"
    assume "\<not>y < k +1"
    hence a:"k + 1 \<le> y" by simp

    have d:"Suc k < length xs" using a b by simp

    have "k+1 = card ((!) xs ` {0..k})"
      by (subst card_image[OF inj_xs], simp)
    also have "... \<le> rank_of (xs ! (k+1)) (set xs)"
      unfolding rank_of_def using k_bound
      by (intro card_mono image_subsetI conjI, simp_all) (metis count_list_ge_2_iff no_col not_le le_imp_less_Suc s_xs
          sorted_iff_nth_mono d order_less_le)
    also have "... \<le> rank_of (xs ! y) (set xs)"
      unfolding rank_of_def
      by (intro card_mono subsetI, simp_all)
       (metis Suc_eq_plus1 a b s_xs order_less_le_trans sorted_iff_nth_mono)
    also assume "... < k+1"
    finally show "False" by force
  qed

  moreover have "rank_of (xs ! y) (set xs) < k+1" if a:"y < k + 1" for y
  proof -
    have "rank_of (xs ! y) (set xs) \<le> card ((\<lambda>k. xs ! k) ` {k. k < length xs \<and> xs ! k < xs ! y})"
      unfolding rank_of_def
      by (intro card_mono subsetI, simp)
       (metis (no_types, lifting) imageI in_set_conv_nth mem_Collect_eq)
    also have "... \<le> card {k. k < length xs \<and> xs ! k < xs ! y}"
      by (rule card_image_le, simp)
    also have "... \<le> card {k. k < y}"
      by (intro card_mono subsetI, simp_all add:not_less)
       (metis sorted_iff_nth_mono s_xs linorder_not_less)
    also have "... = y" by simp
    also have "... < k + 1" using a by simp
    finally show "rank_of (xs ! y) (set xs) < k+1" by simp
  qed

  ultimately have rank_conv: "\<And>y. y < length xs \<Longrightarrow> rank_of (xs ! y) (set xs) < k+1 \<longleftrightarrow> y < k+1"
    by blast

  have "y \<le> xs ! k"  if a:"y \<in> least (k+1) (set xs)"  for y
  proof -
    have "y \<in> set xs" using a least_subset by blast
    then obtain i where i_bound: "i < length xs" and y_def: "y = xs ! i" using in_set_conv_nth by metis
    hence "rank_of (xs ! i) (set xs) < k+1"
      using a y_def i_bound by (simp add: least_def)
    hence "i < k+1"
      using rank_conv i_bound by blast
    hence "i \<le> k" by linarith
    hence "xs ! i \<le> xs ! k"
      using s_xs i_bound k_bound sorted_nth_mono by blast
    thus "y \<le> xs ! k" using y_def by simp
  qed

  moreover have "xs ! k \<in> least (k+1) (set xs)"
    using k_bound rank_conv by (simp add:least_def)

  ultimately have "Max (least (k+1) (set xs)) = xs ! k"
    by (intro Max_eqI finite_subset[OF least_subset], auto)

  hence "nth_mset k A = Max (K_Smallest.least (Suc k) (set xs))"
    by (simp add:nth_mset_def xs_def[symmetric])
  also have "... = Max (least (k+1) (set_mset A))"
    by (simp add:A_def)
  finally show "nth_mset k A = Max (least (k+1) (set_mset A))"  by simp

  have "k + 1 = card ((\<lambda>i. xs ! i) ` {0..k})"
    by (subst card_image[OF inj_xs], simp)
  also have "... \<le> card (least (k+1) (set xs))"
    using rank_conv k_bound
    by (intro card_mono image_subsetI finite_subset[OF least_subset], simp_all add:least_def)
  finally have "card (least (k+1) (set xs)) \<ge> k+1" by simp
  moreover have "card (least (k+1) (set xs)) \<le> k+1"
    by (subst card_least, simp, simp)
  ultimately have "card (least (k+1) (set xs)) = k+1" by simp
  thus "card (least (k+1) (set_mset A)) = k+1"  by (simp add:A_def)
qed

end