(*<*)
theory KuratowskiClosureComplementTheorem
imports
  "HOL-Analysis.Multivariate_Analysis"
  "HOL-Analysis.Continuum_Not_Denumerable"
begin

(*>*)
section\<open> Introduction \<close>

text\<open>

We discuss a topological curiosity discovered by \<^cite>\<open>"Kuratowski:1922"\<close>: the fact that the number of distinct operators on
a topological space generated by compositions of closure and
complement never exceeds 14, and is exactly 14 in the case of @{term
"\<real>"}. In addition, we prove a theorem due to \<^cite>\<open>"Chagrov:1982"\<close> that classifies topological spaces according to the
number of such operators they support.

Kuratowski's result, which is exposited in \<^cite>\<open>"TheoremOfTheDay:2015"\<close> and Chapter 7 of \<^cite>\<open>"Chamberland:2015"\<close>,
has already been treated in Mizar --- see \<^cite>\<open>"BaginskaGrabowski:2003"\<close> and \<^cite>\<open>"Grabowski:2004"\<close>. To the best of
our knowledge, we are the first to mechanize Chagrov's result.

Our work is based on a presentation of Kuratowski's and Chagrov's
results by \<^cite>\<open>"GardnerJackson:2008"\<close>.

We begin with some preliminary facts pertaining to the relationship
between interiors of unions and unions of interiors
(\S\ref{sec:interiors-unions}) and the relationship between @{term
"\<rat>"} and @{term "\<real>"} (\S\ref{sec:rat-real}). We then prove
Kuratowski's result (\S\ref{sec:kuratowski}) and the corollary that at
most 7 distinct operators on a topological space can be generated by
compositions of closure and interior
(\S\ref{sec:kuratowski-corollary}). Finally, we prove Chagrov's result
(\S\ref{sec:chagrov}).

\<close>

section\<open> Interiors and unions \label{sec:interiors-unions} \<close>

definition
  boundary :: "'a::topological_space set \<Rightarrow> 'a set"
where
  "boundary X = closure X - interior X"

lemma boundary_empty:
  shows "boundary {} = {}"
unfolding boundary_def by simp

definition
  exterior :: "'a::topological_space set \<Rightarrow> 'a set"
where
  "exterior X = - (interior X \<union> boundary X)"

lemma interior_union_boundary:
  shows "interior (X \<union> Y) = interior X \<union> interior Y
           \<longleftrightarrow> boundary X \<inter> boundary Y \<subseteq> boundary (X \<union> Y)" (is "(?lhs1 = ?lhs2) \<longleftrightarrow> ?rhs")
proof(rule iffI[OF _ subset_antisym[OF subsetI]])
  assume "?lhs1 = ?lhs2" then show ?rhs by (force simp: boundary_def)
next
  fix x
  assume ?rhs and "x \<in> ?lhs1"
  have "x \<in> ?lhs2" if "x \<notin> interior X" "x \<notin> interior Y"
  proof(cases "x \<in> boundary X \<inter> boundary Y")
    case True with \<open>?rhs\<close> \<open>x \<in> ?lhs1\<close> show ?thesis by (simp add: boundary_def subset_iff)
  next
    case False then consider (X) "x \<notin> boundary X" | (Y) "x \<notin> boundary Y" by blast
    then show ?thesis
    proof cases
      case X
      from X \<open>x \<notin> interior X\<close> have "x \<in> exterior X" by (simp add: exterior_def)
      from \<open>x \<notin> boundary X\<close> \<open>x \<in> exterior X\<close> \<open>x \<notin> interior X\<close>
      obtain U where "open U" "U \<subseteq> - X" "x \<in> U"
        by (metis ComplI DiffI boundary_def closure_interior interior_subset open_interior)
      from \<open>x \<in> interior (X \<union> Y)\<close> obtain U' where "open U'" "U' \<subseteq> X \<union> Y" "x \<in> U'"
        by (meson interiorE)
      from \<open>U \<subseteq> - X\<close> \<open>U' \<subseteq> X \<union> Y\<close> have "U \<inter> U' \<subseteq> Y" by blast
      with \<open>x \<notin> interior Y\<close> \<open>open U'\<close> \<open>open U\<close> \<open>x \<in> U'\<close> \<open>x \<in> U\<close> show ?thesis
        by (meson IntI interiorI open_Int)
    next
      case Y
      from Y \<open>x \<notin> interior Y\<close> have "x \<in> exterior Y" by (simp add: exterior_def)
      from \<open>x \<notin> boundary Y\<close> \<open>x \<in> exterior Y\<close> \<open>x \<notin> interior Y\<close>
      obtain U where "open U" "U \<subseteq> - Y" "x \<in> U"
        by (metis ComplI DiffI boundary_def closure_interior interior_subset open_interior)
      from \<open>x \<in> interior (X \<union> Y)\<close> obtain U' where "open U'" "U' \<subseteq> X \<union> Y" "x \<in> U'"
        by (meson interiorE)
      from \<open>U \<subseteq> -Y\<close> \<open>U' \<subseteq> X \<union> Y\<close> have "U \<inter> U' \<subseteq> X" by blast
      with \<open>x \<notin> interior X\<close> \<open>open U'\<close> \<open>open U\<close> \<open>x \<in> U'\<close> \<open>x \<in> U\<close> show ?thesis
        by (meson IntI interiorI open_Int)
    qed
  qed
  with \<open>x \<in> ?lhs1\<close> show "x \<in> ?lhs2" by blast
next
  show "?lhs2 \<subseteq> ?lhs1" by (simp add: interior_mono)
qed

lemma interior_union_closed_intervals:
  fixes a :: "'a::ordered_euclidean_space"
  assumes "b < c"
  shows "interior ({a..b} \<union> {c..d}) = interior {a..b} \<union> interior {c..d}"
using assms by (subst interior_union_boundary; auto simp: boundary_def)

section\<open> Additional facts about the rationals and reals \label{sec:rat-real} \<close>

lemma Rat_interval_closure:
  fixes x :: real
  assumes "x < y"
  shows "closure ({x<..<y} \<inter> \<rat>) = {x..y}"
using assms
by (metis (no_types, lifting) Rat_closure closure_closure closure_greaterThanLessThan closure_mono inf_le1 inf_top.right_neutral open_Int_closure_subset open_real_greaterThanLessThan subset_antisym)

lemma Rat_not_open:
  fixes T :: "real set"
  assumes "open T"
  assumes "T \<noteq> {}"
  shows "\<not>T \<subseteq> \<rat>"
using assms by (simp add: countable_rat open_minus_countable subset_eq)

lemma Irrat_dense_in_real:
  fixes x :: real
  assumes "x < y"
  shows "\<exists>r\<in>-\<rat>. x < r \<and> r < y"
using assms Rat_not_open[where T="{x<..<y}"] by force

lemma closed_interval_Int_compl:
  fixes x :: real
  assumes "x < y"
  assumes "y < z"
  shows "- {x..y} \<inter> - {y..z} = - {x..z}"
using assms by auto

section\<open> Kuratowski's result \label{sec:kuratowski} \<close>

text\<open>

We prove that at most 14 distinct operators can be generated by compositions of @{const "closure"} and complement. For convenience, we give these operators short names and try to avoid pointwise reasoning. We treat the @{const "interior"} operator at the same time.

\<close>

declare o_apply[simp del]

definition C :: "'a::topological_space set \<Rightarrow> 'a set" where "C X = - X"

definition K :: "'a::topological_space set \<Rightarrow> 'a set" where "K X = closure X"

definition I :: "'a::topological_space set \<Rightarrow> 'a set" where "I X = interior X"

lemma C_C:
  shows "C \<circ> C = id"
by (simp add: fun_eq_iff C_def o_apply)

lemma K_K:
  shows "K \<circ> K = K"
by (simp add: fun_eq_iff K_def o_apply)

lemma I_I:
  shows "I \<circ> I = I"
unfolding I_def by (simp add: o_def)

lemma I_K:
  shows "I = C \<circ> K \<circ> C"
unfolding C_def I_def K_def by (simp add: o_def interior_closure)

lemma K_I:
  shows "K = C \<circ> I \<circ> C"
unfolding C_def I_def K_def by (simp add: o_def interior_closure)

lemma K_I_K_I:
  shows "K \<circ> I \<circ> K \<circ> I = K \<circ> I"
unfolding C_def I_def K_def
by (clarsimp simp: fun_eq_iff o_apply closure_minimal closure_mono closure_subset interior_maximal interior_subset subset_antisym)

lemma I_K_I_K:
  shows "I \<circ> K \<circ> I \<circ> K = I \<circ> K"
unfolding C_def I_def K_def
by (simp add: fun_eq_iff o_apply)
   (metis (no_types) closure_closure closure_mono closure_subset interior_maximal interior_mono interior_subset open_interior subset_antisym)

lemma K_mono:
  assumes "x \<subseteq> y"
  shows "K x \<subseteq> K y"
using assms unfolding K_def by (simp add: closure_mono)

text\<open>

The following lemma embodies the crucial observation about compositions of @{const "C"} and @{const "K"}:

\<close>

lemma KCKCKCK_KCK:
  shows "K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K = K \<circ> C \<circ> K" (is "?lhs = ?rhs")
proof(rule ext[OF equalityI])
  fix x
  have "(C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K) x \<subseteq> ?rhs x" by (simp add: C_def K_def closure_def o_apply)
  then have "(K \<circ> (C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K)) x \<subseteq> (K \<circ> ?rhs) x" by (simp add: K_mono o_apply)
  then show "?lhs x \<subseteq> ?rhs x" by (simp add: K_K o_assoc)
next
  fix x :: "'a::topological_space set"
  have "(C \<circ> K \<circ> C \<circ> K) x \<subseteq> K x" by (simp add: C_def K_def closure_def o_apply)
  then have "(K \<circ> (C \<circ> K \<circ> C \<circ> K)) x \<subseteq> (K \<circ> K) x" by (simp add: K_mono o_apply)
  then have "(C \<circ> (K \<circ> K)) x \<subseteq> (C \<circ> (K \<circ> (C \<circ> K \<circ> C \<circ> K))) x" by (simp add: C_def o_apply)
  then have "(K \<circ> (C \<circ> (K \<circ> K))) x \<subseteq> (K \<circ> (C \<circ> (K \<circ> (C \<circ> K \<circ> C \<circ> K)))) x" by (simp add: K_mono o_apply)
  then show "?rhs x \<subseteq> ?lhs x" by (simp add: K_K o_assoc)
qed

text\<open>

The inductive set \<open>CK\<close> captures all operators that can be generated by compositions of @{const "C"} and @{const "K"}. We shallowly embed the operators; that is, we identify operators up to extensional equality.

\<close>

inductive CK :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "CK C"
| "CK K"
| "\<lbrakk> CK f; CK g \<rbrakk> \<Longrightarrow> CK (f \<circ> g)"

declare CK.intros[intro!]

lemma CK_id[intro!]:
  "CK id"
by (metis CK.intros(1) CK.intros(3) C_C)

text\<open>

The inductive set \<open>CK_nf\<close> captures the normal forms for the 14 distinct operators.

\<close>

inductive CK_nf :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "CK_nf id"
| "CK_nf C"
| "CK_nf K"
| "CK_nf (C \<circ> K)"
| "CK_nf (K \<circ> C)"
| "CK_nf (C \<circ> K \<circ> C)"
| "CK_nf (K \<circ> C \<circ> K)"
| "CK_nf (C \<circ> K \<circ> C \<circ> K)"
| "CK_nf (K \<circ> C \<circ> K \<circ> C)"
| "CK_nf (C \<circ> K \<circ> C \<circ> K \<circ> C)"
| "CK_nf (K \<circ> C \<circ> K \<circ> C \<circ> K)"
| "CK_nf (C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K)"
| "CK_nf (K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C)"
| "CK_nf (C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C)"

declare CK_nf.intros[intro!]

lemma CK_nf_set:
  shows "{f . CK_nf f} = {id, C, K, C \<circ> K, K \<circ> C, C \<circ> K \<circ> C, K \<circ> C \<circ> K, C \<circ> K \<circ> C \<circ> K, K \<circ> C \<circ> K \<circ> C, C \<circ> K \<circ> C \<circ> K \<circ> C, K \<circ> C \<circ> K \<circ> C \<circ> K, C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K, K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C, C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C}"
by (auto simp: CK_nf.simps)

text\<open>

That each operator generated by compositions of @{const "C"} and
@{const "K"} is extensionally equivalent to one of the normal forms
captured by \<open>CK_nf\<close> is demonstrated by means of an
induction over the construction of \<open>CK_nf\<close> and an appeal
to the facts proved above.

\<close>

theorem CK_nf:
  "CK f \<longleftrightarrow> CK_nf f"
proof(rule iffI)
  assume "CK f" then show "CK_nf f"
    by induct
       (elim CK_nf.cases; clarsimp simp: id_def[symmetric] C_C K_K KCKCKCK_KCK o_assoc; simp add: o_assoc[symmetric]; clarsimp simp: C_C K_K KCKCKCK_KCK o_assoc
      | blast)+
next
  assume "CK_nf f" then show "CK f" by induct (auto simp: id_def[symmetric])
qed

theorem CK_card:
  shows "card {f. CK f} \<le> 14"
by (auto simp: CK_nf CK_nf_set card.insert_remove intro!: le_trans[OF card_Diff1_le])

text\<open>

We show, using the following subset of \<open>\<real>\<close> (an
example taken from \<^cite>\<open>"Rusin:2001"\<close>) as a witness, that there
exist topological spaces on which all 14 operators are distinct.

\<close>

definition
  RRR :: "real set"
where
  "RRR = {0<..<1} \<union> {1<..<2} \<union> {3} \<union> ({5<..<7} \<inter> \<rat>)"

text\<open>

The following facts allow the required proofs to proceed by @{method simp}:

\<close>

lemma RRR_closure:
  shows "closure RRR = {0..2} \<union> {3} \<union> {5..7}"
unfolding RRR_def by (force simp: closure_insert Rat_interval_closure)

lemma RRR_interior:
  "interior RRR = {0<..<1} \<union> {1<..<2}" (is "?lhs = ?rhs")
proof(rule equalityI[OF subsetI subsetI])
  fix x assume "x \<in> ?lhs"
  then obtain T where "open T" and "x \<in> T" and "T \<subseteq> RRR" by (blast elim: interiorE)
  then obtain e where "0 < e" and "ball x e \<subseteq> T" by (blast elim!: openE)
  from \<open>x \<in> T\<close> \<open>0 < e\<close> \<open>ball x e \<subseteq> T\<close> \<open>T \<subseteq> RRR\<close>
  have False if "x = 3"
    using that unfolding RRR_def ball_def
    by (auto dest!: subsetD[where c="min (3 + e/2) 4"] simp: dist_real_def)
  moreover
  from Irrat_dense_in_real[where x="x" and y="x + e/2"] \<open>0 < e\<close>
  obtain r where "r\<in>- \<rat> \<and> x < r \<and> r < x + e / 2" by auto
  with \<open>x \<in> T\<close>  \<open>ball x e \<subseteq> T\<close> \<open>T \<subseteq> RRR\<close>
  have False if "x \<in> {5<..<7} \<inter> \<rat>"
    using that unfolding RRR_def ball_def
    by (force simp: dist_real_def dest: subsetD[where c=r])
  moreover note \<open>x \<in> interior RRR\<close>
  ultimately show "x \<in> ?rhs"
    unfolding RRR_def by (auto dest: subsetD[OF interior_subset])
next
  fix x assume "x \<in> ?rhs"
  then show "x \<in> ?lhs"
    unfolding RRR_def interior_def by (auto intro: open_real_greaterThanLessThan)
qed

lemma RRR_interior_closure[simplified]:
  shows "interior ({0::real..2} \<union> {3} \<union> {5..7}) = {0<..<2} \<union> {5<..<7}" (is "?lhs = ?rhs")
proof -
  have "?lhs = interior ({0..2} \<union> {5..7})"
    by (metis (no_types, lifting) Un_assoc Un_commute closed_Un closed_eucl_atLeastAtMost interior_closed_Un_empty_interior interior_singleton)
  also have "... = ?rhs"
    by (simp add: interior_union_closed_intervals)
  finally show ?thesis .
qed

text\<open>

The operators can be distinguished by testing which of the points in
\<open>{1,2,3,4,6}\<close> belong to their results.

\<close>

definition
  test :: "(real set \<Rightarrow> real set) \<Rightarrow> bool list"
where
  "test f \<equiv> map (\<lambda>x. x \<in> f RRR) [1,2,3,4,6]"

lemma RRR_test:
  assumes "f RRR = g RRR"
  shows "test f = test g"
unfolding test_def using assms by simp

lemma nf_RRR:
  shows
    "test id = [False, False, True, False, True]"
    "test C = [True, True, False, True, False]"
    "test K = [True, True, True, False, True]"
    "test (K \<circ> C) = [True, True, True, True, True]"
    "test (C \<circ> K) = [False, False, False, True, False]"
    "test (C \<circ> K \<circ> C) = [False, False, False, False, False]"
    "test (K \<circ> C \<circ> K) = [False, True, True, True, False]"
    "test (C \<circ> K \<circ> C \<circ> K) = [True, False, False, False, True]"
    "test (K \<circ> C \<circ> K \<circ> C) = [True, True, False, False, False]"
    "test (C \<circ> K \<circ> C \<circ> K \<circ> C) = [False, False, True, True, True]"
    "test (K \<circ> C \<circ> K \<circ> C \<circ> K) = [True, True, False, False, True]"
    "test (C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K) = [False, False, True, True, False]"
    "test (K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C) = [False, True, True, True, True]"
    "test (C \<circ> K \<circ> C \<circ> K \<circ> C \<circ> K \<circ> C) = [True, False, False, False, False]"
unfolding test_def C_def K_def
by (simp_all add: RRR_closure RRR_interior RRR_interior_closure closure_complement closed_interval_Int_compl o_apply)
   (simp_all add: RRR_def)

theorem CK_nf_real_card:
  shows "card ((\<lambda> f. f RRR) ` {f . CK_nf f}) = 14"
by (simp add: CK_nf_set) ((subst card_insert_disjoint; auto dest!: RRR_test simp: nf_RRR id_def[symmetric])[1])+

theorem CK_real_card:
  shows "card {f::real set \<Rightarrow> real set. CK f} = 14" (is "?lhs = ?rhs")
proof(rule antisym[OF CK_card])
  show "?rhs \<le> ?lhs"
    unfolding CK_nf
    by (rule le_trans[OF eq_imp_le[OF CK_nf_real_card[symmetric]] card_image_le])
       (simp add: CK_nf_set)
qed

section\<open> A corollary of Kuratowski's result \label{sec:kuratowski-corollary} \<close>

text\<open>

We show that it is a corollary of @{thm [source] CK_real_card} that at
most 7 distinct operators on a topological space can be generated by
compositions of closure and interior. In the case of
\<open>\<real>\<close>, exactly 7 distinct operators can be so
generated.

\<close>

inductive IK :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "IK id"
| "IK I"
| "IK K"
| "\<lbrakk> IK f; IK g \<rbrakk> \<Longrightarrow> IK (f \<circ> g)"

inductive IK_nf :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "IK_nf id"
| "IK_nf I"
| "IK_nf K"
| "IK_nf (I \<circ> K)"
| "IK_nf (K \<circ> I)"
| "IK_nf (I \<circ> K \<circ> I)"
| "IK_nf (K \<circ> I \<circ> K)"

declare IK.intros[intro!]

declare IK_nf.intros[intro!]

lemma IK_nf_set:
  "{f . IK_nf f} = {id, I, K, I \<circ> K, K \<circ> I, I \<circ> K \<circ> I, K \<circ> I \<circ> K}"
by (auto simp: IK_nf.simps)

theorem IK_nf:
  "IK f \<longleftrightarrow> IK_nf f"
proof(rule iffI)
  assume "IK f" then show "IK_nf f"
    by induct
       (elim IK_nf.cases; clarsimp simp: id_def[symmetric] o_assoc; simp add: I_I K_K o_assoc[symmetric]; clarsimp simp: K_I_K_I I_K_I_K o_assoc
      | blast)+
next
  assume "IK_nf f" then show "IK f" by induct blast+
qed

theorem IK_card:
  shows "card {f. IK f} \<le> 7"
by (auto simp: IK_nf IK_nf_set card.insert_remove intro!: le_trans[OF card_Diff1_le])

theorem IK_nf_real_card:
  shows "card ((\<lambda> f. f RRR) ` {f . IK_nf f}) = 7"
by (simp add: IK_nf_set) ((subst card_insert_disjoint; auto dest!: RRR_test simp: nf_RRR I_K id_def[symmetric] o_assoc)[1])+

theorem IK_real_card:
  shows "card {f::real set \<Rightarrow> real set. IK f} = 7" (is "?lhs = ?rhs")
proof(rule antisym[OF IK_card])
  show "?rhs \<le> ?lhs"
    unfolding IK_nf
    by (rule le_trans[OF eq_refl[OF IK_nf_real_card[symmetric]] card_image_le])
       (simp add: IK_nf_set)
qed

section\<open> Chagrov's result \label{sec:chagrov} \<close>

text\<open>

Chagrov's theorem, which is discussed in Section 2.1 of \<^cite>\<open>"GardnerJackson:2008"\<close>, states that the number of distinct operators
on a topological space that can be generated by compositions of
closure and complement is one of 2, 6, 8, 10 or 14.

We begin by observing that the set of normal forms @{const "CK_nf"}
can be split into two disjoint sets, @{term "CK_nf_pos"} and @{term
"CK_nf_neg"}, which we define in terms of interior and closure.

\<close>

inductive CK_nf_pos :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "CK_nf_pos id"
| "CK_nf_pos I"
| "CK_nf_pos K"
| "CK_nf_pos (I \<circ> K)"
| "CK_nf_pos (K \<circ> I)"
| "CK_nf_pos (I \<circ> K \<circ> I)"
| "CK_nf_pos (K \<circ> I \<circ> K)"

declare CK_nf_pos.intros[intro!]

lemma CK_nf_pos_set:
  shows "{f . CK_nf_pos f} = {id, I, K, I \<circ> K, K \<circ> I, I \<circ> K \<circ> I, K \<circ> I \<circ> K}"
by (auto simp: CK_nf_pos.simps)

definition
  CK_nf_neg :: "('a::topological_space set \<Rightarrow> 'a set) \<Rightarrow> bool"
where
  "CK_nf_neg f \<longleftrightarrow> (\<exists>g. CK_nf_pos g \<and> f = C \<circ> g)"

lemma CK_nf_pos_neg_disjoint:
  assumes "CK_nf_pos f"
  assumes "CK_nf_neg g"
  shows "f \<noteq> g"
using assms unfolding CK_nf_neg_def
by (clarsimp simp: CK_nf_pos.simps; elim disjE; metis comp_def C_def I_def K_def Compl_iff closure_UNIV interior_UNIV id_apply)

lemma CK_nf_pos_neg_CK_nf:
  "CK_nf f \<longleftrightarrow> CK_nf_pos f \<or> CK_nf_neg f" (is "?lhs \<longleftrightarrow> ?rhs")
proof(rule iffI)
  assume ?lhs then show ?rhs
    unfolding CK_nf_neg_def
    by (rule CK_nf.cases; metis (no_types, lifting) CK_nf_pos.simps C_C I_K K_I comp_id o_assoc)
next
  assume ?rhs then show ?lhs
    unfolding CK_nf_neg_def
    by (auto elim!: CK_nf_pos.cases simp: I_K C_C o_assoc)
qed

text\<open>

We now focus on @{const "CK_nf_pos"}. In particular, we show that its
cardinality for any given topological space is one of 1, 3, 4, 5 or 7.

The proof consists of exhibiting normal forms for the operators
supported by each of six classes of topological spaces. These are
sublattices of the following lattice of @{const CK_nf_pos} operators:

\<close>

lemmas K_I_K_subseteq_K = closure_mono[OF interior_subset, of "closure X", simplified] for X

lemma CK_nf_pos_lattice:
  shows
    "I \<le> (id :: 'a::topological_space set \<Rightarrow> 'a set)"
    "id \<le> (K :: 'a::topological_space set \<Rightarrow> 'a set)"
    "I \<le> I \<circ> K \<circ> (I :: 'a::topological_space set \<Rightarrow> 'a set)"
    "I \<circ> K \<circ> I \<le> I \<circ> (K :: 'a::topological_space set \<Rightarrow> 'a set)"
    "I \<circ> K \<circ> I \<le> K \<circ> (I :: 'a::topological_space set \<Rightarrow> 'a set)"
    "I \<circ> K \<le> K \<circ> I \<circ> (K :: 'a::topological_space set \<Rightarrow> 'a set)"
    "K \<circ> I \<le> K \<circ> I \<circ> (K :: 'a::topological_space set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K \<le> (K :: 'a::topological_space set \<Rightarrow> 'a set)"
unfolding I_def K_def
by (simp_all add: interior_subset closure_subset interior_maximal closure_mono o_apply interior_mono K_I_K_subseteq_K le_funI)

text\<open>

We define the six classes of topological spaces in question, and show
that they are related by inclusion in the following way (as shown in
Figure 2.3 of \<^cite>\<open>"GardnerJackson:2008"\<close>):

\begin{center}
 \begin{tikzpicture}[scale=.7]
  \node (d) at (30:5cm) {Open unresolvable spaces};
  \node (one) at (90:5cm) {Kuratowski spaces};
  \node (b) at (150:5cm) {Extremally disconnected spaces};
  \node (a) at (210:5cm) {Partition spaces};
  \node (zero) at (270:5cm) {Discrete spaces};
  \node (c) at (330:5cm) {\hspace{1cm}Extremally disconnected and open unresolvable spaces};
  \draw (zero) -- (a) -- (b) -- (one) -- (d) -- (c) -- (zero);
  \draw (c) -- (b);
 \end{tikzpicture}
\end{center}

\<close>

subsection\<open> Discrete spaces \<close>

definition
  "discrete (X :: 'a::topological_space set) \<longleftrightarrow> I = (id::'a set \<Rightarrow> 'a set)"

lemma discrete_eqs:
  assumes "discrete (X :: 'a::topological_space set)"
  shows
    "I  = (id::'a set \<Rightarrow> 'a set)"
    "K  = (id::'a set \<Rightarrow> 'a set)"
using assms unfolding discrete_def by (auto simp: C_C K_I)

lemma discrete_card:
  assumes "discrete (X :: 'a::topological_space set)"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 1"
using discrete_eqs[OF assms] CK_nf_pos_lattice[where 'a='a] by (simp add: CK_nf_pos_set)

lemma discrete_discrete_topology:
  fixes X :: "'a::topological_space set"
  assumes "\<And>Y::'a set. open Y"
  shows "discrete X"
using assms unfolding discrete_def I_def interior_def islimpt_def by (auto simp: fun_eq_iff)

subsection\<open> Partition spaces \<close>

definition
  "part (X :: 'a::topological_space set) \<longleftrightarrow> K \<circ> I = (I :: 'a set \<Rightarrow> 'a set)"

lemma discrete_part:
  assumes "discrete X"
  shows "part X"
using assms unfolding discrete_def part_def by (simp add: C_C K_I)

lemma part_eqs:
  assumes "part (X :: 'a::topological_space set)"
  shows
    "K \<circ> I = (I :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K = (K :: 'a set \<Rightarrow> 'a set)"
using assms unfolding part_def by (assumption, metis (no_types, opaque_lifting) I_I K_I o_assoc)

lemma part_not_discrete_card:
  assumes "part (X :: 'a::topological_space set)"
  assumes "\<not>discrete X"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 3"
using part_eqs[OF \<open>part X\<close>] \<open>\<not>discrete X\<close> CK_nf_pos_lattice[where 'a='a]
unfolding discrete_def
by (simp add: CK_nf_pos_set card_insert_if C_C I_K K_K o_assoc; metis comp_id)

text\<open>

A partition space is a topological space whose basis consists of the empty set and the equivalence classes of points of the space induced by some equivalence relation @{term "R"} on the underlying set of the space. Equivalently, a partition space is one in which every open set is closed. Thus, for example, the class of partition spaces includes every topological space whose open sets form a boolean algebra.

\<close>

datatype part_witness = a | b | c

lemma part_witness_UNIV:
  shows "UNIV = set [a, b, c]"
using part_witness.exhaust by auto

lemmas part_witness_pow = subset_subseqs[OF subset_trans[OF subset_UNIV Set.equalityD1[OF part_witness_UNIV]]]

lemmas part_witness_Compl = Compl_eq_Diff_UNIV[where 'a=part_witness, unfolded part_witness_UNIV, simplified]

instantiation part_witness :: topological_space
begin

definition "open_part_witness X \<longleftrightarrow> X \<in> {{}, {a}, {b, c}, {a, b, c}}"

lemma part_witness_ball:
  "(\<forall>s\<in>S. s \<in> {{}, {a}, {b, c}, {a, b, c}}) \<longleftrightarrow> S \<subseteq> set [{}, {a}, {b, c}, {a, b, c}]"
by simp blast

lemmas part_witness_subsets_pow = subset_subseqs[OF iffD1[OF part_witness_ball]]

instance proof standard
  fix K :: "part_witness set set"
  assume "\<forall>S\<in>K. open S" then show "open (\<Union>K)"
    unfolding open_part_witness_def
    by - (drule part_witness_subsets_pow; clarsimp; elim disjE; simp add: insert_commute)
qed (auto simp: open_part_witness_def part_witness_UNIV)

end

lemma part_witness_interior_simps:
  shows
    "interior {a} = {a}"
    "interior {b} = {}"
    "interior {c} = {}"
    "interior {a, b} = {a}"
    "interior {a, c} = {a}"
    "interior {b, c} = {b, c}"
    "interior {a, b, c} = {a, b, c}"
unfolding interior_def open_part_witness_def by auto

lemma part_witness_part:
  fixes X :: "part_witness set"
  shows "part X"
proof -
  have "closure (interior Y) = interior Y" for Y :: "part_witness set"
    using part_witness_pow[where X=Y]
    by (auto simp: closure_interior part_witness_interior_simps part_witness_Compl insert_Diff_if)
  then show ?thesis
    unfolding part_def I_def K_def by (simp add: o_def)
qed

lemma part_witness_not_discrete:
  fixes X :: "part_witness set"
  shows "\<not>discrete X"
unfolding discrete_def I_def
by (clarsimp simp: o_apply fun_eq_iff exI[where x="{b}"] part_witness_interior_simps)

lemma part_witness_card:
  shows "card {f. CK_nf_pos (f::part_witness set \<Rightarrow> part_witness set)} = 3"
by (rule part_not_discrete_card[OF part_witness_part part_witness_not_discrete])

subsection\<open> Extremally disconnected and open unresolvable spaces \<close>

definition
  "ed_ou (X :: 'a::topological_space set) \<longleftrightarrow> I \<circ> K = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"

lemma discrete_ed_ou:
  assumes "discrete X"
  shows "ed_ou X"
using assms unfolding discrete_def ed_ou_def by simp

lemma ed_ou_eqs:
  assumes "ed_ou (X :: 'a::topological_space set)"
  shows
    "I \<circ> K \<circ> I = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
using assms unfolding ed_ou_def by (metis I_I K_K o_assoc)+

lemma ed_ou_neqs:
  assumes "ed_ou (X :: 'a::topological_space set)"
  assumes "\<not>discrete X"
  shows
    "I \<noteq> (K :: 'a set \<Rightarrow> 'a set)"
    "I \<noteq> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "K \<noteq> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "I \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
    "K \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
using assms CK_nf_pos_lattice[where 'a='a]
unfolding ed_ou_def discrete_def
by (metis (no_types, lifting) C_C I_K K_I comp_id o_assoc antisym)+

lemma ed_ou_not_discrete_card:
  assumes "ed_ou (X :: 'a::topological_space set)"
  assumes "\<not>discrete X"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 4"
using ed_ou_eqs[OF \<open>ed_ou X\<close>] ed_ou_neqs[OF assms]
by (subst CK_nf_pos_set) (subst card_insert_disjoint; (auto)[1])+

text\<open>

We consider an example extremally disconnected and open unresolvable topological space.

\<close>

datatype ed_ou_witness = a | b | c | d | e

lemma ed_ou_witness_UNIV:
  shows "UNIV = set [a, b, c, d, e]"
using ed_ou_witness.exhaust by auto

lemmas ed_ou_witness_pow = subset_subseqs[OF subset_trans[OF subset_UNIV Set.equalityD1[OF ed_ou_witness_UNIV]]]

lemmas ed_ou_witness_Compl = Compl_eq_Diff_UNIV[where 'a=ed_ou_witness, unfolded ed_ou_witness_UNIV, simplified]

instance ed_ou_witness :: finite
by standard (simp add: ed_ou_witness_UNIV)

instantiation ed_ou_witness :: topological_space
begin

inductive open_ed_ou_witness :: "ed_ou_witness set \<Rightarrow> bool" where
  "open_ed_ou_witness {}"
| "open_ed_ou_witness {a}"
| "open_ed_ou_witness {b}"
| "open_ed_ou_witness {e}"
| "open_ed_ou_witness {a, c}"
| "open_ed_ou_witness {b, d}"
| "open_ed_ou_witness {a, c, e}"

| "open_ed_ou_witness {a, b}"
| "open_ed_ou_witness {a, e}"
| "open_ed_ou_witness {b, e}"
| "open_ed_ou_witness {a, b, c}"
| "open_ed_ou_witness {a, b, d}"
| "open_ed_ou_witness {a, b, e}"
| "open_ed_ou_witness {b, d, e}"
| "open_ed_ou_witness {a, b, c, d}"
| "open_ed_ou_witness {a, b, c, e}"
| "open_ed_ou_witness {a, b, d, e}"
| "open_ed_ou_witness {a, b, c, d, e}"

declare open_ed_ou_witness.intros[intro!]

lemma ed_ou_witness_inter:
  fixes S :: "ed_ou_witness set"
  assumes "open S"
  assumes "open T"
  shows "open (S \<inter> T)"
using assms by (auto elim!: open_ed_ou_witness.cases)

lemma ed_ou_witness_union:
  fixes X :: "ed_ou_witness set set"
  assumes "\<forall>x\<in>X. open x"
  shows "open (\<Union>X)"
using finite[of X] assms
by (induct, force)
   (clarsimp; elim open_ed_ou_witness.cases; simp add: open_ed_ou_witness.simps subset_insertI2 insert_commute; metis Union_empty_conv)

instance
by standard (auto simp: ed_ou_witness_UNIV intro: ed_ou_witness_inter ed_ou_witness_union)

end

lemma ed_ou_witness_interior_simps:
  shows
    "interior {a} = {a}"
    "interior {b} = {b}"
    "interior {c} = {}"
    "interior {d} = {}"
    "interior {e} = {e}"
    "interior {a, b} = {a, b}"
    "interior {a, c} = {a, c}"
    "interior {a, d} = {a}"
    "interior {a, e} = {a, e}"
    "interior {b, c} = {b}"
    "interior {b, d} = {b, d}"
    "interior {b, e} = {b, e}"
    "interior {c, d} = {}"
    "interior {c, e} = {e}"
    "interior {d, e} = {e}"
    "interior {a, b, c} = {a, b, c}"
    "interior {a, b, d} = {a, b, d}"
    "interior {a, b, e} = {a, b, e}"
    "interior {a, c, d} = {a, c}"
    "interior {a, c, e} = {a, c, e}"
    "interior {a, d, e} = {a, e}"
    "interior {b, c, d} = {b, d}"
    "interior {b, c, e} = {b, e}"
    "interior {b, d, e} = {b, d, e}"
    "interior {c, d, e} = {e}"
    "interior {a, b, c, d} = {a, b, c, d}"
    "interior {a, b, c, e} = {a, b, c, e}"
    "interior {a, b, d, e} = {a, b, d, e}"
    "interior {a, b, c, d, e} = {a, b, c, d, e}"
    "interior {a, c, d, e} = {a, c, e}"
    "interior {b, c, d, e} = {b, d, e}"
unfolding interior_def by safe (clarsimp simp: open_ed_ou_witness.simps; blast)+

lemma ed_ou_witness_not_discrete:
  fixes X :: "ed_ou_witness set"
  shows "\<not>discrete X"
unfolding discrete_def I_def using ed_ou_witness_interior_simps by (force simp: fun_eq_iff)

lemma ed_ou_witness_ed_ou:
  fixes X :: "ed_ou_witness set"
  shows "ed_ou X"
unfolding ed_ou_def I_def K_def
proof(clarsimp simp: o_apply fun_eq_iff)
  fix x :: "ed_ou_witness set"
  from ed_ou_witness_pow[of x]
  show "interior (closure x) = closure (interior x)"
    by - (simp; elim disjE; simp add: closure_interior ed_ou_witness_interior_simps ed_ou_witness_Compl insert_Diff_if)
qed

lemma ed_ou_witness_card:
  shows "card {f. CK_nf_pos (f::ed_ou_witness set \<Rightarrow> ed_ou_witness set)} = 4"
by (rule ed_ou_not_discrete_card[OF ed_ou_witness_ed_ou ed_ou_witness_not_discrete])

subsection\<open> Extremally disconnected spaces \<close>

definition
  "extremally_disconnected (X :: 'a::topological_space set) \<longleftrightarrow> K \<circ> I \<circ> K = I \<circ> (K :: 'a set \<Rightarrow> 'a set)"

lemma ed_ou_part_extremally_disconnected:
  assumes "ed_ou X"
  assumes "part X"
  shows "extremally_disconnected X"
using assms unfolding extremally_disconnected_def ed_ou_def part_def by simp

lemma extremally_disconnected_eqs:
  fixes X :: "'a::topological_space set"
  assumes "extremally_disconnected X"
  shows
    "I \<circ> K \<circ> I = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K = I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
using assms unfolding extremally_disconnected_def by (metis K_I_K_I)+

lemma extremally_disconnected_not_part_not_ed_ou_card:
  fixes X :: "'a::topological_space set"
  assumes "extremally_disconnected X"
  assumes "\<not>part X"
  assumes "\<not>ed_ou X"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 5"
using extremally_disconnected_eqs[OF \<open>extremally_disconnected X\<close>] CK_nf_pos_lattice[where 'a='a] assms(2,3)
unfolding part_def ed_ou_def
by (simp add: CK_nf_pos_set C_C I_K K_K o_assoc card_insert_if; metis (no_types) C_C K_I id_comp o_assoc)

text\<open>

Any topological space having an infinite underlying set and whose topology consists of the empty set and every cofinite subset of the underlying set is extremally disconnected. We consider an example such space having a countably infinite underlying set.

\<close>

datatype 'a cofinite = cofinite 'a

instantiation cofinite :: (type) topological_space
begin

definition "open_cofinite = (\<lambda>X::'a cofinite set. finite (-X) \<or> X = {})"

instance
by standard (auto simp: open_cofinite_def uminus_Sup)

end

lemma cofinite_closure_finite:
  fixes X :: "'a cofinite set"
  assumes "finite X"
  shows "closure X = X"
using assms by (simp add: closed_open open_cofinite_def)

lemma cofinite_closure_infinite:
  fixes X :: "'a cofinite set"
  assumes "infinite X"
  shows "closure X = UNIV"
using assms by (metis Compl_empty_eq closure_subset double_compl finite_subset interior_complement open_cofinite_def open_interior)

lemma cofinite_interior_finite:
  fixes X :: "'a cofinite set"
  assumes "finite X"
  assumes "infinite (UNIV::'a cofinite set)"
  shows "interior X = {}"
using assms cofinite_closure_infinite[where X="-X"] by (simp add: interior_closure)

lemma cofinite_interior_infinite:
  fixes X :: "'a cofinite set"
  assumes "infinite X"
  assumes "infinite (-X)"
  shows "interior X = {}"
using assms cofinite_closure_infinite[where X="-X"] by (simp add: interior_closure)

abbreviation "evens :: nat cofinite set \<equiv> {cofinite n | n. \<exists>i. n=2*i}"

lemma evens_infinite:
  shows "infinite evens"
proof(rule iffD2[OF infinite_iff_countable_subset], rule exI, rule conjI)
  let ?f = "\<lambda>n::nat. cofinite (2*n)"
  show "inj ?f" by (auto intro: inj_onI)
  show "range ?f \<subseteq> evens" by auto
qed

lemma cofinite_nat_infinite:
  shows "infinite (UNIV::nat cofinite set)"
using evens_infinite finite_Diff2 by fastforce

lemma evens_Compl_infinite:
  shows "infinite (- evens)"
proof(rule iffD2[OF infinite_iff_countable_subset], rule exI, rule conjI)
  let ?f = "\<lambda>n::nat. cofinite (2*n+1)"
  show "inj ?f" by (auto intro: inj_onI)
  show "range ?f \<subseteq> -evens" by clarsimp presburger
qed

lemma evens_interior:
  shows "interior evens = {}"
using evens_infinite evens_Compl_infinite by (rule cofinite_interior_infinite)

lemma cofinite_not_part:
  fixes X :: "nat cofinite set"
  shows "\<not>part X"
unfolding part_def I_def K_def
using cofinite_nat_infinite
by (clarsimp simp: fun_eq_iff o_apply)
   (metis (no_types) cofinite_closure_finite cofinite_interior_finite double_compl finite.emptyI finite.insertI insert_not_empty interior_closure)

lemma cofinite_not_ed_ou:
  fixes X :: "nat cofinite set"
  shows "\<not>ed_ou X"
unfolding ed_ou_def I_def K_def
by (clarsimp simp: fun_eq_iff o_apply evens_closure evens_interior exI[where x="evens"])

lemma cofinite_extremally_disconnected_aux:
  fixes X :: "nat cofinite set"
  shows "closure (interior (closure X)) \<subseteq> interior (closure X)"
by (metis subsetI closure_closure closure_complement closure_def closure_empty finite_Un interior_eq open_cofinite_def open_interior)

lemma cofinite_extremally_disconnected:
  fixes X :: "nat cofinite set"
  shows "extremally_disconnected X"
unfolding extremally_disconnected_def I_def K_def
by (auto simp: fun_eq_iff o_apply dest: subsetD[OF closure_subset] subsetD[OF interior_subset] subsetD[OF cofinite_extremally_disconnected_aux])

lemma cofinite_card:
  shows "card {f. CK_nf_pos (f::nat cofinite set \<Rightarrow> nat cofinite set)} = 5"
by (rule extremally_disconnected_not_part_not_ed_ou_card[OF cofinite_extremally_disconnected cofinite_not_part cofinite_not_ed_ou])

subsection\<open> Open unresolvable spaces \<close>

definition
  "open_unresolvable (X :: 'a::topological_space set) \<longleftrightarrow> K \<circ> I \<circ> K = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"

lemma ed_ou_open_unresolvable:
  assumes "ed_ou X"
  shows "open_unresolvable X"
using assms unfolding open_unresolvable_def by (simp add: ed_ou_eqs)

lemma open_unresolvable_eqs:
  assumes "open_unresolvable (X :: 'a::topological_space set)"
  shows
    "I \<circ> K \<circ> I = I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K = K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
using assms unfolding open_unresolvable_def by - (metis I_K_I_K o_assoc; simp)

lemma not_ed_ou_neqs:
  assumes "\<not>ed_ou (X :: 'a::topological_space set)"
  shows
    "I \<noteq> I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
    "K \<noteq> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
using assms unfolding ed_ou_def
by (simp_all add: fun_eq_iff I_K K_def C_def o_apply)
   (metis (no_types, opaque_lifting) closure_eq_empty disjoint_eq_subset_Compl double_complement interior_Int interior_complement set_eq_subset)+

lemma open_unresolvable_not_ed_ou_card:
  assumes "open_unresolvable (X :: 'a::topological_space set)"
  assumes "\<not>ed_ou X"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 5"
using open_unresolvable_eqs[OF \<open>open_unresolvable X\<close>] not_ed_ou_neqs[OF \<open>\<not>ed_ou X\<close>] \<open>\<not>ed_ou X\<close>
unfolding ed_ou_def by (auto simp: CK_nf_pos_set card_insert_if)

text\<open>

We show that the class of open unresolvable spaces is non-empty by exhibiting an example of such a space.

\<close>

datatype ou_witness = a | b | c

lemma ou_witness_UNIV:
  shows "UNIV = set [a, b, c]"
using ou_witness.exhaust by auto

instantiation ou_witness :: topological_space
begin

definition "open_ou_witness X \<longleftrightarrow> a \<notin> X \<or> X = UNIV"

instance
by standard (auto simp: open_ou_witness_def)

end

lemma ou_witness_closure_simps:
  shows
    "closure {a} = {a}"
    "closure {b} = {a, b}"
    "closure {c} = {a, c}"
    "closure {a, b} = {a, b}"
    "closure {a, c} = {a, c}"
    "closure {a, b, c} = {a, b, c}"
    "closure {b, c} = {a, b, c}"
unfolding closure_def islimpt_def open_ou_witness_def by force+

lemma ou_witness_open_unresolvable:
  fixes X :: "ou_witness set"
  shows "open_unresolvable X"
unfolding open_unresolvable_def I_def K_def
by (clarsimp simp: o_apply fun_eq_iff)
   (metis (no_types, lifting) Compl_iff K_I_K_subseteq_K closure_complement closure_interior closure_mono closure_subset interior_eq interior_maximal open_ou_witness_def subset_antisym)

lemma ou_witness_not_ed_ou:
  fixes X :: "ou_witness set"
  shows "\<not>ed_ou X"
unfolding ed_ou_def I_def K_def
by (clarsimp simp: o_apply fun_eq_iff)
   (metis UNIV_I insert_iff interior_eq open_ou_witness_def singletonD
          ou_witness.distinct(4,5) ou_witness.simps(2) ou_witness_closure_simps(2))

lemma ou_witness_card:
  shows "card {f. CK_nf_pos (f::ou_witness set \<Rightarrow> ou_witness set)} = 5"
by (rule open_unresolvable_not_ed_ou_card[OF ou_witness_open_unresolvable ou_witness_not_ed_ou])

subsection\<open> Kuratowski spaces \<close>

definition
  "kuratowski (X :: 'a::topological_space set) \<longleftrightarrow>
    \<not>extremally_disconnected X \<and> \<not>open_unresolvable X"

text\<open>

A Kuratowski space distinguishes all 7 positive operators.

\<close>

lemma part_closed_open:
  fixes X :: "'a::topological_space set"
  assumes "I \<circ> K \<circ> I = (I::'a set \<Rightarrow> 'a set)"
  assumes "closed X"
  shows "open X"
proof(rule Topological_Spaces.openI)
  fix x assume "x \<in> X"
  let ?S = "I (-{x})"
  let ?G = "-K ?S"
  have "x \<in> ?G"
  proof -
    from \<open>I \<circ> K \<circ> I = I\<close> have "I (K (I ?S)) = ?S" "I ?S = ?S"
      unfolding I_def K_def by (simp_all add: o_def fun_eq_iff)
    then have "K (I ?S) \<noteq> UNIV"
      unfolding I_def K_def using interior_subset by fastforce
    moreover have "G \<subseteq> ?S \<or> x \<in> G" if "open G" for G
      using that unfolding I_def by (meson interior_maximal subset_Compl_singleton)
    ultimately show ?thesis
      unfolding I_def K_def
      by clarsimp (metis (no_types, lifting) ComplD Compl_empty_eq closure_interior closure_subset ex_in_conv open_interior subset_eq)
  qed
  moreover from \<open>I \<circ> K \<circ> I = I\<close> have "open ?G"
    unfolding I_def K_def by (auto simp: fun_eq_iff o_apply)
  moreover have "?G \<subseteq> X"
  proof -
    have "?G \<subseteq> K ?G" unfolding K_def using closure_subset by fastforce
    also from \<open>I \<circ> K \<circ> I = I\<close> have "... = K {x}"
      unfolding I_def K_def by (metis closure_interior comp_def double_complement)
    also from \<open>closed X\<close> \<open>x \<in> X\<close> have "... \<subseteq> X"
      unfolding K_def by clarsimp (meson closure_minimal contra_subsetD empty_subsetI insert_subset)
    finally show ?thesis .
  qed
  ultimately show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> X" by blast
qed

lemma part_I_K_I:
  assumes "I \<circ> K \<circ> I = (I::'a::topological_space set \<Rightarrow> 'a set)"
  shows "I \<circ> K = (K::'a set \<Rightarrow> 'a set)"
using interior_open[OF part_closed_open[OF assms closed_closure]] unfolding I_def K_def o_def by simp

lemma part_K_I_I:
  assumes "I \<circ> K \<circ> I = (I::'a::topological_space set \<Rightarrow> 'a set)"
  shows "K \<circ> I = (I::'a set \<Rightarrow> 'a set)"
using part_I_K_I[OF assms] assms by simp

lemma kuratowski_neqs:
  assumes "kuratowski (X :: 'a::topological_space set)"
  shows
    "I \<noteq> I \<circ> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K \<circ> I \<noteq> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K \<circ> I \<noteq> I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K \<noteq> K \<circ> I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<noteq> K \<circ> I \<circ> (K :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K \<noteq> (K :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K \<noteq> K \<circ> (I :: 'a set \<Rightarrow> 'a set)"
    "I \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
    "K \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
    "I \<circ> K \<circ> I \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
    "K \<circ> I \<circ> K \<noteq> (id :: 'a set \<Rightarrow> 'a set)"
using assms unfolding kuratowski_def extremally_disconnected_def open_unresolvable_def
by (metis (no_types, lifting) I_K K_K I_K_I_K K_I_K_I part_I_K_I part_K_I_I o_assoc comp_id)+

lemma kuratowski_card:
  assumes "kuratowski (X :: 'a::topological_space set)"
  shows "card {f. CK_nf_pos (f::'a set \<Rightarrow> 'a set)} = 7"
using CK_nf_pos_lattice[where 'a='a] kuratowski_neqs[OF assms] assms
unfolding kuratowski_def extremally_disconnected_def open_unresolvable_def
by (subst CK_nf_pos_set) (subst card_insert_disjoint; (auto)[1])+

text\<open>

\<open>\<real>\<close> is a Kuratowski space.

\<close>

lemma kuratowski_reals:
  shows "kuratowski (\<real> :: real set)"
unfolding kuratowski_def extremally_disconnected_def open_unresolvable_def
by (rule conjI)
   (metis (no_types, lifting) I_K list.inject nf_RRR(11) nf_RRR(8) o_assoc,
    metis (no_types, lifting) I_K fun.map_comp list.inject nf_RRR(11) nf_RRR(9))

subsection\<open> Chagrov's theorem \<close>

theorem chagrov:
  fixes X :: "'a::topological_space set"
  obtains "discrete X"
        | "\<not>discrete X \<and> part X"
        | "\<not>discrete X \<and> ed_ou X"
        | "\<not>ed_ou X \<and> open_unresolvable X"
        | "\<not>ed_ou X \<and> \<not>part X \<and> extremally_disconnected X"
        | "kuratowski X"
unfolding kuratowski_def by metis

corollary chagrov_card:
  shows "card {f. CK_nf_pos (f::'a::topological_space set \<Rightarrow> 'a set)} \<in> {1,3,4,5,7}"
using discrete_card part_not_discrete_card ed_ou_not_discrete_card open_unresolvable_not_ed_ou_card
      extremally_disconnected_not_part_not_ed_ou_card kuratowski_card
by (cases rule: chagrov) blast+
(*<*)

end
(*>*)


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

section \<open>Derivative algebra\<close>
text\<open>\noindent{The closure of a set A (@{text "\<C>(A)"}) can be seen as the set A augmented by (i) its boundary points, or
(ii) its accumulation/limit points. We explore the second variant by drawing on the notion of derivative algebra.}\<close>

text\<open>\noindent{Declares a primitive (unconstrained) derivative (aka. derived-set) operation and defines others from it.}\<close>
consts \<D>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<I>\<^sub>D \<D>" \<comment>\<open> interior \<close>
abbreviation "\<C> \<equiv> \<C>\<^sub>D \<D>" \<comment>\<open> closure \<close>
abbreviation "\<B> \<equiv> \<B>\<^sub>D \<D>" \<comment>\<open> border \<close>
abbreviation "\<F> \<equiv> \<F>\<^sub>D \<D>" \<comment>\<open> frontier \<close>
abbreviation "\<K> \<equiv> \<K>\<^sub>D \<D>" \<comment>\<open> coherence \<close>

subsection \<open>Basic properties\<close>

text\<open>\noindent{Verifies minimal conditions under which operators resulting from conversion functions coincide.}\<close>
lemma ICdual: "\<I> \<^bold>\<equiv> \<C>\<^sup>d" by (simp add: dual_der2 equal_op_def)
lemma ICdual': "\<C> \<^bold>\<equiv> \<I>\<^sup>d" by (simp add: dual_der1 equal_op_def)

text\<open>\noindent{Recall that derivative and coherence operations cannot be obtained from either interior, closure, border
nor frontier. The derivative operation can indeed be seen as being more fundamental than the other ones.}\<close>

text\<open>\noindent{Fixed-point and other operators are interestingly related.}\<close>
lemma fp1: "\<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" by (smt BI_rel Br_int_def IB_rel Int_br_def equal_op_def conn)
lemma fp2: "\<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using Br_der_def Int_der_def unfolding equal_op_def conn by auto
lemma fp3: "\<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" by (smt BI_rel Br_int_def CB_rel Cl_br_def dual_def equal_op_def conn)
lemma fp4: "(\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "\<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" using Br_der_def Cl_der_def Fr_der_def unfolding equal_op_def conn by auto
lemma fp6: "\<D>\<^sup>f\<^sup>p \<^bold>\<equiv> \<K> \<^bold>\<squnion> (\<C>\<^sup>c)" using Cl_der_def Kh_der_def equal_op_def conn by fastforce

text\<open>\noindent{Different inter-relations (some redundant ones are kept to help the provers).}\<close>
lemma monI: "Der_1b \<D> \<Longrightarrow> MONO \<I>" by (simp add: ID1b MONO_MULTa)
lemma monC: "Der_1b \<D> \<Longrightarrow> MONO \<C>" by (simp add: CD1b MONO_ADDIb)
lemma pB1: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<I> A" using BI_rel Br_int_def eq_ext' by fastforce
lemma pB2: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<and> \<F> A" using Br_der_def Fr_der_def conn by auto
lemma pB3: "\<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<F> A" using FD2 Fr_2_def meet_def pB2 by auto
lemma pB4: "\<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<C> A" by (simp add: dual_def dual_der1 pB1 conn)
lemma pB5: "Der_1b \<D> \<Longrightarrow> \<forall>A. \<B>(\<C> A) \<^bold>\<preceq> (\<B> A) \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using ADDI_b_def Cl_der_def MONO_ADDIb monI pB1 pB4 unfolding conn by auto
lemma pF1: "\<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<I> A"  using Cl_der_def Fr_der_def Int_der_def conn by auto
lemma pF2: "\<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)" by (simp add: Cl_der_def Fr_der_def2)
lemma pF3: "\<forall>A. \<F> A \<^bold>\<approx> \<B> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" by (smt Br_der_def Cl_der_def dual_def dual_der1 dual_der2 pF2 conn)
lemma pF4: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. \<F>(\<I> A) \<^bold>\<preceq> \<F> A" by (metis CD1 CD2 CD4a ICdual ID4 IDEM_def PC1 PC4 PC5 PD8 diff_def eq_ext' pF1)
lemma pF5: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. \<F>(\<C> A) \<^bold>\<preceq> \<F> A" by (metis FD2 Fr_2_def ICdual' dual_def eq_ext' pF4)
lemma pA1: "\<forall>A. A \<^bold>\<approx> \<I> A \<^bold>\<or> \<B> A" using Br_der_def2 Int_der_def2 conn by auto
lemma pA2: "\<forall>A. A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<B>(\<^bold>\<midarrow>A)" using Cl_der_def pB4 conn by auto
lemma pC1: "\<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using CB_rel Cl_br_def eq_ext' by fastforce
lemma pC2: "\<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<F> A" using Cl_der_def Fr_der_def2 conn by auto
lemma pI1: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<B> A" using pA1 pB1 conn by auto
lemma pI2: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<F> A" using Br_der_def Fr_der_def pI1 conn by auto

lemma IC_imp: "Der_1 \<D> \<Longrightarrow> Der_3 \<D> \<Longrightarrow> \<forall>A B. \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<C> A \<^bold>\<rightarrow> \<C> B" proof -
  assume der1: "Der_1 \<D>" and der3: "Der_3 \<D>"
  { fix a b
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a = \<^bold>\<top>" unfolding conn by auto
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<I>(\<^bold>\<top>)" by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" using der3 dNOR_def using ID3 by auto
    moreover have "let A=(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b; B=\<^bold>\<midarrow>a in \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<I>(A) \<^bold>\<rightarrow> \<I>(B)" using ID1 Int_7_def PI7 der1 by auto
    ultimately have "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "let A=a \<^bold>\<rightarrow> b; B=\<^bold>\<midarrow>b in \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I>(A) \<^bold>\<and> \<I>(B)" using ID1 MULT_def der1 by auto
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(\<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "\<forall>A. \<I>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>\<C>(A)" by (simp add: dual_def dual_der1 conn)
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<rightarrow> \<^bold>\<midarrow>\<C>(a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<preceq> \<^bold>\<midarrow>\<C>(a)" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<C> a \<^bold>\<preceq> \<C> b" unfolding conn by metis
  } thus ?thesis unfolding conn by simp
qed

text\<open>\noindent{Define some fixed-point predicates and prove some properties.}\<close>
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: "Der_1a \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. Op(\<I> A)" using ID4a IDEM_def by blast
lemma Cl_Closed: "Der_1a \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. Cl(\<C> A)" using CD4a IDEM_def by blast
lemma Br_Border: "Der_1b \<D> \<Longrightarrow> \<forall>A. Br(\<B> A)" by (smt Br_der_def CI1b IC1_dual PD1 conn)
text\<open>\noindent{In contrast, there is no analogous fixed-point result for frontier:}\<close>
lemma "\<DD> \<D> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all derivative conditions*)

lemma OpCldual: "\<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" using dual_def dual_der1 conn by auto
lemma ClOpdual: "\<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" by (simp add: dual_def dual_der1 conn)
lemma Fr_ClBr: "\<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using join_def meet_def pB2 pC2 by auto
lemma Cl_F: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. Cl(\<F> A)" using FD4 Fr_4_def join_def pC2 by auto

subsection \<open>Further properties\<close>

text\<open>\noindent{The definitions and theorems below are well known in the literature (e.g. \<^cite>\<open>Kuratowski2\<close>).
Here we uncover the minimal conditions under which they hold (taking derivative operation as primitive).}\<close>
lemma Cl_Bzero: "\<forall>A. Cl A \<longleftrightarrow> \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<bottom>" using pA2 pC1 unfolding conn by metis
lemma Op_Bzero: "\<forall>A. Op A \<longleftrightarrow>  \<B> A \<^bold>\<approx> \<^bold>\<bottom>" using pB1 pI1 unfolding conn by metis
lemma Br_boundary: "\<forall>A. Br(A) \<longleftrightarrow> \<I> A \<^bold>\<approx> \<^bold>\<bottom>" using Br_der_def2 Int_der_def2 unfolding conn by metis
lemma Fr_nowhereDense: "\<forall>A. Fr(A) \<longrightarrow> \<I>(\<C> A) \<^bold>\<approx> \<^bold>\<bottom>" using Fr_ClBr Br_boundary eq_ext by metis
lemma Cl_FB: "\<forall>A. Cl A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B> A" using Br_der_def2 pA2 pF1 pF3 unfolding conn by metis
lemma Op_FB: "\<forall>A. Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B>(\<^bold>\<midarrow>A)" using pA1 pA2 pF3 pI2 unfolding conn by metis
lemma Clopen_Fzero: "\<forall>A. Cl A \<and> Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<^bold>\<bottom>" using Cl_der_def Int_der_def Fr_der_def unfolding conn by smt

lemma Int_sup_closed: "Der_1b \<D> \<Longrightarrow> supremum_closed (\<lambda>A. Op A)" by (smt IC1_dual ID1b Int_der_def2 PD1 sup_char diff_def)

text\<open>\noindent{Introduces a predicate for indicating that two sets are disjoint and proves some properties.}\<close>
abbreviation "Disj A B \<equiv> A \<^bold>\<and> B \<^bold>\<approx> \<^bold>\<bottom>"

lemma Disj_comm: "\<forall>A B. Disj A B \<longrightarrow> Disj B A" unfolding conn by fastforce
lemma Disj_IF: "\<forall>A. Disj (\<I> A) (\<F> A)" by (simp add: Cl_der_def Fr_der_def2 dual_def dual_der2 conn)
lemma Disj_B: "\<forall>A. Disj (\<B> A) (\<B>(\<^bold>\<midarrow>A))" by (simp add: Br_der_def2 conn)
lemma Disj_I: "\<forall>A. Disj (\<I> A) (\<^bold>\<midarrow>A)" by (simp add: Int_der_def conn)
lemma Disj_BCI: "\<forall>A. Disj (\<B>(\<C> A)) (\<I>(\<^bold>\<midarrow>A))" by (simp add: Br_der_def2 dual_def dual_der1 conn)
lemma Disj_CBI: "Der_1b \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. Disj (\<C>(\<B>(\<^bold>\<midarrow>A))) (\<I>(\<^bold>\<midarrow>A))" by (smt Br_der_def2 Der_4e_def Cl_der_def Int_der_def2 PD3 conn)

text\<open>\noindent{Introduce a predicate for indicating that two sets are separated and proves some properties.}\<close>
definition "Sep A B \<equiv> Disj (\<C> A) B \<and> Disj (\<C> B) A"

lemma Sep_comm: "\<forall>A B. Sep A B \<longrightarrow> Sep B A" by (simp add: Sep_def)
lemma Sep_disj: "\<forall>A B. Sep A B \<longrightarrow> Disj A B" using CD2 EXP_def Sep_def conn by auto
lemma Sep_I: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A. Sep (\<I> A) (\<I> (\<^bold>\<midarrow>A))" unfolding Sep_def by (smt CD2 CD4 IC1 ID1 PC4 PC5 PD8 dual_def dual_der1 dual_der2 conn)

lemma Sep_sub: "Der_1b \<D> \<Longrightarrow> \<forall>A B C D. Sep A B \<and> C \<^bold>\<preceq> A \<and> D \<^bold>\<preceq> B \<longrightarrow> Sep C D" using MONO_ADDIb PD2 dual_der1 monI unfolding Sep_def conn by metis
lemma Sep_Cl_diff: "Der_1b \<D> \<Longrightarrow> \<forall>A B. Cl(A) \<and> Cl(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" unfolding Sep_def using CD1b PD1 bottom_def diff_def meet_def by smt
lemma Sep_Op_diff: "Der_1b \<D> \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" proof -
  assume der1b:"Der_1b \<D>"
  { fix A B
    from der1b have aux: "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>B in (Cl(M) \<and> Cl(N) \<longrightarrow> Sep (M \<^bold>\<leftharpoonup> N) (N \<^bold>\<leftharpoonup> M))" using Sep_Cl_diff by simp
    { assume "Op(A) \<and> Op(B)"
      hence "Cl(\<^bold>\<midarrow>A) \<and> Cl(\<^bold>\<midarrow>B)" using der1b ClOpdual by simp
      hence "Sep (\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) (\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A)" using der1b aux unfolding conn by simp
      moreover have "(\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) \<^bold>\<approx> (B \<^bold>\<leftharpoonup> A)" unfolding conn by auto
      moreover have "(\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A) \<^bold>\<approx> (A \<^bold>\<leftharpoonup> B)" unfolding conn by auto
      ultimately have "Sep (B \<^bold>\<leftharpoonup> A) (A \<^bold>\<leftharpoonup> B)" unfolding conn by simp
      hence "Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_comm by simp
    } hence "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" by (rule impI)
  } thus ?thesis by simp
qed
lemma Sep_Cl: "\<forall>A B. Cl(A) \<and> Cl(B) \<and> Disj A B \<longrightarrow> Sep A B" unfolding Sep_def conn by blast
lemma Sep_Op: "Der_1b \<D>  \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" proof -
  assume der1b:"Der_1b \<D>"
  { fix A B
    from der1b have aux: "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_Op_diff by simp
    { assume op: "Op(A) \<and> Op(B)" and disj: "Disj A B"
      hence "(A \<^bold>\<leftharpoonup> B) \<^bold>\<approx> A \<and> (B \<^bold>\<leftharpoonup> A) \<^bold>\<approx> B" unfolding conn by blast
      hence "Sep A B" using op aux unfolding conn by simp
    } hence "Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" by simp
  } thus ?thesis by simp
qed
lemma "Der_1a \<D> \<Longrightarrow> \<forall>A B C. Sep A B \<and> Sep A C \<longrightarrow> Sep A (B \<^bold>\<or> C)" using ADDI_a_def CD1a unfolding Sep_def conn by metis

text\<open>\noindent{Verifies a neighborhood-based definition of interior.}\<close>
definition "nbhd A p \<equiv> \<exists>E. E \<^bold>\<preceq> A \<and> Op(E) \<and> (E p)"
lemma nbhd_def2: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> \<forall>A p. (nbhd A p) = (\<I> A p)" unfolding nbhd_def by (smt Int_Open MONO_def PC1 monI pI2 conn)

lemma I_def'_lr': "\<forall>A p. (\<I> A p) \<longrightarrow> (\<exists>E. (\<I> E p) \<and> E \<^bold>\<preceq> A)" by blast
lemma I_def'_rl': "Der_1b \<D> \<Longrightarrow> \<forall>A p. (\<I> A p) \<longleftarrow> (\<exists>E. (\<I> E p) \<and> E \<^bold>\<preceq> A)" using MONO_def monI by metis
lemma I_def': "Der_1b \<D> \<Longrightarrow>  \<forall>A p. (\<I> A p) \<longleftrightarrow> (\<exists>E. (\<I> E p) \<and> E \<^bold>\<preceq> A)" using MONO_def monI by metis

text\<open>\noindent{Explore the Barcan and converse Barcan formulas.}\<close>
lemma Barcan_I: "Der_inf \<D> \<Longrightarrow> \<forall>P. (\<^bold>\<forall>x. \<I>(P x)) \<^bold>\<preceq> \<I>(\<^bold>\<forall>x. P x)" using ID_inf Barcan1 by auto
lemma Barcan_C: "Der_inf \<D> \<Longrightarrow> \<forall>P. \<C>(\<^bold>\<exists>x. P x) \<^bold>\<preceq> (\<^bold>\<exists>x. \<C>(P x))" using CD_inf Barcan2 by metis
lemma CBarcan_I: "Der_1b \<D> \<Longrightarrow> \<forall>P. \<I>(\<^bold>\<forall>x. P x)  \<^bold>\<preceq> (\<^bold>\<forall>x. \<I>(P x))" by (metis (mono_tags, lifting) MONO_def monI)
lemma CBarcan_C: "Der_1b \<D> \<Longrightarrow> \<forall>P. (\<^bold>\<exists>x. \<C>(P x)) \<^bold>\<preceq> \<C>(\<^bold>\<exists>x. P x)"  by (metis (mono_tags, lifting) MONO_def monC)

end


theory mUnion
  imports mMem
begin

context GZF_Model begin

lemma mUnion_eq :
  assumes x : "x : mSetOf mSet"
  shows "m\<Union> x = <set, \<Union> y \<in> snd x. snd y>"
  unfolding mUnion_def mUnion'_def
  using x by auto

lemma munion_typ :
  "m\<Union> : mSetOf mSet \<rightarrow> mSet"
proof (rule funI, unfold mUnion_eq, rule msetI)
  fix x assume x_setof:"x : mSetOf mSet"
  hence x : "x : mSet" and x_mem : "\<forall>b. b m x \<longrightarrow> b : mSet"
    using msetof_iff by auto
  then obtain x' where
    x':"x = <set,x'>" "x' : Set" using msetE by metis
  then obtain j where
   j: "j : Ord" "<set,x'> \<in> Tier j"
    using mE[OF mset_m[OF x]] by auto
  hence "<set,x'> \<in> Tier (succ (succ j))"
    using tier_succI1 succ_ord by auto
  hence x'_sub : "x' \<subseteq> Tier (succ j)"
    using tierD_mset[OF succ_ord[OF j(1)]] ex_subset2[OF x'(2) tier_set[OF succ_ord[OF j(1)]]] by auto
  have x'_mem : "\<forall>y. y \<in> x' \<longrightarrow> y : mSet"
    using x_mem mmem_iff_eq[OF x x'(1)]
    unfolding x' by auto

  have "\<Union> {snd y | y \<in> snd x} \<subseteq> Tier j \<ominus> set"
    unfolding x'(1) mset_snd_eq'[OF x'(2)]
  proof
    fix b assume "b \<in> \<Union> {snd y | y \<in> x'}"
    then obtain y where "b \<in> snd y" "y \<in> x'"
      using repfun_union[OF _ snd_replfun] mset_pair_setof x_setof x' by auto
    hence "y : mSet" "y \<in> Tier (succ j)"
      using x'_sub x'_mem by auto
    moreover then obtain y' where y':"y = <set,y'>" "y' : Set"
      using msetE by auto
    ultimately have "y' \<subseteq> Tier j \<ominus> set" using tierD_mset[OF j(1)] by auto
    thus "b \<in> Tier j \<ominus> set" using \<open>b \<in> snd y\<close> y' mset_snd_eq' by auto
  qed
  moreover have "\<Union> {snd y | y \<in> snd x} : Set"
    using union_set[OF repfun_setof[OF _ snd_replfun]]
          mset_pair_setof x_setof x' mset_snd_eq' by auto
  ultimately show "<set, \<Union> {snd y | y \<in> snd x}> : M"
    using mI_mset[OF j(1)] by auto
qed

lemmas munion_mset = funE[OF munion_typ]

lemma munionI :
  assumes x : "x : mSetOf mSet"
      and y : "y m x"
      and a : "a m y"
    shows "a m m\<Union> x"
proof (rule msetE[OF msetof_mset[OF x]])
  fix x' assume x':"x = <set,x'>" "x' : Set"
  obtain y' where y': "y = <set, y'>" "y' : Set"
    using msetE[OF msetof_mmem[OF x y]] by auto
  have x'_setof : "x' : SetOf mSet"
    using mset_pair_setof x' x by auto

     thm mmemI_eq[OF munion_mset[OF x]]
  show "a m m\<Union> x"
  proof (rule mmemI_eq[OF munion_mset[OF x]],
         unfold mUnion_eq[OF x], simp)

    from a have "a \<in> snd y"
      using mmemD_eq[OF y'(1) a] mmem_mset[OF a] mset_snd_eq y' by auto
    moreover have "y \<in> x'"
      using mmemD_eq[OF x'(1) y]   by auto
    ultimately show "a \<in> \<Union> { snd y | y \<in> snd x }"
      unfolding mset_snd_eq'[OF x'(2)] x'(1)
      using repfun_union[OF x'(2) snd_replfun[OF x'_setof]]
      by auto
   qed
qed

lemma munionE :
  assumes x : "x : mSetOf mSet"
      and a : "a m m\<Union> x"
  obtains y where "y m x" "a m y"
proof (rule msetofE[OF x])
  fix x' assume x':"x = <set,x'>" "x' : SetOf mSet"
  hence "a \<in> \<Union> RepFun x' \<pi>"
    using a mmemD mUnion_eq[OF x]
    unfolding x' mset_snd_eq'[OF setof_set[OF x'(2)]]  by auto
  then obtain y where "y \<in> x'" "a \<in> snd y"
    using repfun_union[OF setof_set[OF x'(2)] snd_replfun[OF x'(2)]]
    by auto
  then obtain y' where "y = <set,y'>" "y' : Set" "a \<in> y'"
    using msetE[OF setof_mem[OF x'(2)]] mset_snd_eq' by metis

  have "x : mSet" using msetof_mset[OF x] .
  have "y m x" "a m y"
    using mmemI_eq[OF \<open>x : mSet\<close> x'(1) \<open>y \<in> x'\<close>]
          mmemI[OF msetI[OF mmem_m] \<open>a \<in> y'\<close>] \<open>y = <set,y'>\<close>
    by auto
  thus ?thesis ..
qed

lemma munion_iff :
  assumes x : "x : mSetOf mSet"
  shows "b m m\<Union> x \<longleftrightarrow> (\<exists>y. y m x \<and> b m y)"
  using munionI[OF x] munionE[OF x] by metis

theorem munion_ax :
  "m\<forall>x : mSetOf mSet. m\<forall>b. b m m\<Union> x \<longleftrightarrow> (m\<exists>y. y m x \<and> b m y)"
  unfolding mtall_def mall_def tall_def mex_def tex_def
  using munion_iff mmem_m by blast

theorem munion_rsp :
  "x : M \<Longrightarrow> m\<Union> x : M"
  using mset_m[OF munion_mset] GZF_Model_mdefault_m
  unfolding mUnion_def by auto

end
end


(*  Title:      ZF/ZF_Base.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Base of Zermelo-Fraenkel Set Theory\<close>

theory ZF_Base
imports FOL
begin

subsection \<open>Signature\<close>

declare [[eta_contract = false]]

typedecl i
instance i :: "term" ..

axiomatization mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<in>\<close> 50)  \<comment> \<open>membership relation\<close>
  and zero :: "i"  (\<open>0\<close>)  \<comment> \<open>the empty set\<close>
  and Pow :: "i \<Rightarrow> i"  \<comment> \<open>power sets\<close>
  and Inf :: "i"  \<comment> \<open>infinite set\<close>
  and Union :: "i \<Rightarrow> i"  (\<open>\<Union>_\<close> [90] 90)
  and PrimReplace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"

abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

subsection \<open>Bounded Quantifiers\<close>

definition Ball :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Ball(A, P) \<equiv> \<forall>x. x\<in>A \<longrightarrow> P(x)"

definition Bex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Bex(A, P) \<equiv> \<exists>x. x\<in>A \<and> P(x)"

syntax
  "_Ball" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<forall>_\<in>_./ _)\<close> 10)
  "_Bex" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<exists>_\<in>_./ _)\<close> 10)
translations
  "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball(A, \<lambda>x. P)"
  "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex(A, \<lambda>x. P)"

subsection \<open>Variations on Replacement\<close>

(* Derived form of replacement, restricting P to its functional part.
   The resulting set (for functional P) is the same as with
   PrimReplace, but the rules are simpler. *)
definition Replace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"
  where "Replace(A,P) == PrimReplace(A, %x y. (\<exists>!z. P(x,z)) & P(x,y))"

syntax
  "_Replace"  :: "[pttrn, pttrn, i, o] => i"  (\<open>(1{_ ./ _ \<in> _, _})\<close>)
translations
  "{y. x\<in>A, Q}" \<rightleftharpoons> "CONST Replace(A, \<lambda>x y. Q)"

(* Functional form of replacement -- analgous to ML's map functional *)

definition RepFun :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "RepFun(A,f) == {y . x\<in>A, y=f(x)}"

syntax
  "_RepFun" :: "[i, pttrn, i] => i"  (\<open>(1{_ ./ _ \<in> _})\<close> [51,0,51])
translations
  "{b. x\<in>A}" \<rightleftharpoons> "CONST RepFun(A, \<lambda>x. b)"

(* Separation and Pairing can be derived from the Replacement
   and Powerset Axioms using the following definitions. *)
definition Collect :: "[i, i \<Rightarrow> o] \<Rightarrow> i"
  where "Collect(A,P) == {y . x\<in>A, x=y & P(x)}"

syntax
  "_Collect" :: "[pttrn, i, o] \<Rightarrow> i"  (\<open>(1{_ \<in> _ ./ _})\<close>)
translations
  "{x\<in>A. P}" \<rightleftharpoons> "CONST Collect(A, \<lambda>x. P)"

subsection \<open>General union and intersection\<close>

definition Inter :: "i => i"  (\<open>\<Inter>_\<close> [90] 90)
  where "\<Inter>(A) == { x\<in>\<Union>(A) . \<forall>y\<in>A. x\<in>y}"

syntax
  "_UNION" :: "[pttrn, i, i] => i"  (\<open>(3\<Union>_\<in>_./ _)\<close> 10)
  "_INTER" :: "[pttrn, i, i] => i"  (\<open>(3\<Inter>_\<in>_./ _)\<close> 10)
translations
  "\<Union>x\<in>A. B" == "CONST Union({B. x\<in>A})"
  "\<Inter>x\<in>A. B" == "CONST Inter({B. x\<in>A})"

subsection \<open>Finite sets and binary operations\<close>

(*Unordered pairs (Upair) express binary union/intersection and cons;
  set enumerations translate as {a,...,z} = cons(a,...,cons(z,0)...)*)

definition Upair :: "[i, i] => i"
  where "Upair(a,b) == {y. x\<in>Pow(Pow(0)), (x=0 & y=a) | (x=Pow(0) & y=b)}"

definition Subset :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<subseteq>\<close> 50)  \<comment> \<open>subset relation\<close>
  where subset_def: "A \<subseteq> B \<equiv> \<forall>x\<in>A. x\<in>B"

definition Diff :: "[i, i] \<Rightarrow> i"  (infixl \<open>-\<close> 65)  \<comment> \<open>set difference\<close>
  where "A - B == { x\<in>A . ~(x\<in>B) }"

definition Un :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<union>\<close> 65)  \<comment> \<open>binary union\<close>
  where "A \<union> B == \<Union>(Upair(A,B))"

definition Int :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<inter>\<close> 70)  \<comment> \<open>binary intersection\<close>
  where "A \<inter> B == \<Inter>(Upair(A,B))"

definition cons :: "[i, i] => i"
  where "cons(a,A) == Upair(a,a) \<union> A"

definition succ :: "i => i"
  where "succ(i) == cons(i, i)"

nonterminal "is"
syntax
  "" :: "i \<Rightarrow> is"  (\<open>_\<close>)
  "_Enum" :: "[i, is] \<Rightarrow> is"  (\<open>_,/ _\<close>)
  "_Finset" :: "is \<Rightarrow> i"  (\<open>{(_)}\<close>)
translations
  "{x, xs}" == "CONST cons(x, {xs})"
  "{x}" == "CONST cons(x, 0)"

subsection \<open>Axioms\<close>

(* ZF axioms -- see Suppes p.238
   Axioms for Union, Pow and Replace state existence only,
   uniqueness is derivable using extensionality. *)

axiomatization
where
  extension:     "A = B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A" and
  Union_iff:     "A \<in> \<Union>(C) \<longleftrightarrow> (\<exists>B\<in>C. A\<in>B)" and
  Pow_iff:       "A \<in> Pow(B) \<longleftrightarrow> A \<subseteq> B" and

  (*We may name this set, though it is not uniquely defined.*)
  infinity:      "0 \<in> Inf \<and> (\<forall>y\<in>Inf. succ(y) \<in> Inf)" and

  (*This formulation facilitates case analysis on A.*)
  foundation:    "A = 0 \<or> (\<exists>x\<in>A. \<forall>y\<in>x. y\<notin>A)" and

  (*Schema axiom since predicate P is a higher-order variable*)
  replacement:   "(\<forall>x\<in>A. \<forall>y z. P(x,y) \<and> P(x,z) \<longrightarrow> y = z) \<Longrightarrow>
                         b \<in> PrimReplace(A,P) \<longleftrightarrow> (\<exists>x\<in>A. P(x,b))"

subsection \<open>Definite descriptions -- via Replace over the set "1"\<close>

definition The :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder \<open>THE \<close> 10)
  where the_def: "The(P)    == \<Union>({y . x \<in> {0}, P(y)})"

definition If :: "[o, i, i] \<Rightarrow> i"  (\<open>(if (_)/ then (_)/ else (_))\<close> [10] 10)
  where if_def: "if P then a else b == THE z. P & z=a | ~P & z=b"

abbreviation (input)
  old_if :: "[o, i, i] => i"  (\<open>if '(_,_,_')\<close>)
  where "if(P,a,b) == If(P,a,b)"

subsection \<open>Ordered Pairing\<close>

(* this "symmetric" definition works better than {{a}, {a,b}} *)
definition Pair :: "[i, i] => i"
  where "Pair(a,b) == {{a,a}, {a,b}}"

definition fst :: "i \<Rightarrow> i"
  where "fst(p) == THE a. \<exists>b. p = Pair(a, b)"

definition snd :: "i \<Rightarrow> i"
  where "snd(p) == THE b. \<exists>a. p = Pair(a, b)"

definition split :: "[[i, i] \<Rightarrow> 'a, i] \<Rightarrow> 'a::{}"  \<comment> \<open>for pattern-matching\<close>
  where "split(c) == \<lambda>p. c(fst(p), snd(p))"

(* Patterns -- extends pre-defined type "pttrn" used in abstractions *)
nonterminal patterns
syntax
  "_pattern"  :: "patterns => pttrn"         (\<open>\<langle>_\<rangle>\<close>)
  ""          :: "pttrn => patterns"         (\<open>_\<close>)
  "_patterns" :: "[pttrn, patterns] => patterns"  (\<open>_,/_\<close>)
  "_Tuple"    :: "[i, is] => i"              (\<open>\<langle>(_,/ _)\<rangle>\<close>)
translations
  "\<langle>x, y, z\<rangle>"   == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"      == "CONST Pair(x, y)"
  "\<lambda>\<langle>x,y,zs\<rangle>.b" == "CONST split(\<lambda>x \<langle>y,zs\<rangle>.b)"
  "\<lambda>\<langle>x,y\<rangle>.b"    == "CONST split(\<lambda>x y. b)"

definition Sigma :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Sigma(A,B) == \<Union>x\<in>A. \<Union>y\<in>B(x). {\<langle>x,y\<rangle>}"

abbreviation cart_prod :: "[i, i] => i"  (infixr \<open>\<times>\<close> 80)  \<comment> \<open>Cartesian product\<close>
  where "A \<times> B \<equiv> Sigma(A, \<lambda>_. B)"

subsection \<open>Relations and Functions\<close>

(*converse of relation r, inverse of function*)
definition converse :: "i \<Rightarrow> i"
  where "converse(r) == {z. w\<in>r, \<exists>x y. w=\<langle>x,y\<rangle> \<and> z=\<langle>y,x\<rangle>}"

definition domain :: "i \<Rightarrow> i"
  where "domain(r) == {x. w\<in>r, \<exists>y. w=\<langle>x,y\<rangle>}"

definition range :: "i \<Rightarrow> i"
  where "range(r) == domain(converse(r))"

definition field :: "i \<Rightarrow> i"
  where "field(r) == domain(r) \<union> range(r)"

definition relation :: "i \<Rightarrow> o"  \<comment> \<open>recognizes sets of pairs\<close>
  where "relation(r) == \<forall>z\<in>r. \<exists>x y. z = \<langle>x,y\<rangle>"

definition "function" :: "i \<Rightarrow> o"  \<comment> \<open>recognizes functions; can have non-pairs\<close>
  where "function(r) == \<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> (\<forall>y'. \<langle>x,y'\<rangle> \<in> r \<longrightarrow> y = y')"

definition Image :: "[i, i] \<Rightarrow> i"  (infixl \<open>``\<close> 90)  \<comment> \<open>image\<close>
  where image_def: "r `` A  == {y \<in> range(r). \<exists>x\<in>A. \<langle>x,y\<rangle> \<in> r}"

definition vimage :: "[i, i] \<Rightarrow> i"  (infixl \<open>-``\<close> 90)  \<comment> \<open>inverse image\<close>
  where vimage_def: "r -`` A == converse(r)``A"

(* Restrict the relation r to the domain A *)
definition restrict :: "[i, i] \<Rightarrow> i"
  where "restrict(r,A) == {z \<in> r. \<exists>x\<in>A. \<exists>y. z = \<langle>x,y\<rangle>}"

(* Abstraction, application and Cartesian product of a family of sets *)

definition Lambda :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where lam_def: "Lambda(A,b) == {\<langle>x,b(x)\<rangle>. x\<in>A}"

definition "apply" :: "[i, i] \<Rightarrow> i"  (infixl \<open>`\<close> 90)  \<comment> \<open>function application\<close>
  where "f`a == \<Union>(f``{a})"

definition Pi :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Pi(A,B) == {f\<in>Pow(Sigma(A,B)). A\<subseteq>domain(f) & function(f)}"

abbreviation function_space :: "[i, i] \<Rightarrow> i"  (infixr \<open>\<rightarrow>\<close> 60)  \<comment> \<open>function space\<close>
  where "A \<rightarrow> B \<equiv> Pi(A, \<lambda>_. B)"

(* binder syntax *)

syntax
  "_PROD"     :: "[pttrn, i, i] => i"        (\<open>(3\<Prod>_\<in>_./ _)\<close> 10)
  "_SUM"      :: "[pttrn, i, i] => i"        (\<open>(3\<Sum>_\<in>_./ _)\<close> 10)
  "_lam"      :: "[pttrn, i, i] => i"        (\<open>(3\<lambda>_\<in>_./ _)\<close> 10)
translations
  "\<Prod>x\<in>A. B"   == "CONST Pi(A, \<lambda>x. B)"
  "\<Sum>x\<in>A. B"   == "CONST Sigma(A, \<lambda>x. B)"
  "\<lambda>x\<in>A. f"    == "CONST Lambda(A, \<lambda>x. f)"

subsection \<open>ASCII syntax\<close>

notation (ASCII)
  cart_prod       (infixr \<open>*\<close> 80) and
  Int             (infixl \<open>Int\<close> 70) and
  Un              (infixl \<open>Un\<close> 65) and
  function_space  (infixr \<open>->\<close> 60) and
  Subset          (infixl \<open><=\<close> 50) and
  mem             (infixl \<open>:\<close> 50) and
  not_mem         (infixl \<open>~:\<close> 50)

syntax (ASCII)
  "_Ball"     :: "[pttrn, i, o] => o"        (\<open>(3ALL _:_./ _)\<close> 10)
  "_Bex"      :: "[pttrn, i, o] => o"        (\<open>(3EX _:_./ _)\<close> 10)
  "_Collect"  :: "[pttrn, i, o] => i"        (\<open>(1{_: _ ./ _})\<close>)
  "_Replace"  :: "[pttrn, pttrn, i, o] => i" (\<open>(1{_ ./ _: _, _})\<close>)
  "_RepFun"   :: "[i, pttrn, i] => i"        (\<open>(1{_ ./ _: _})\<close> [51,0,51])
  "_UNION"    :: "[pttrn, i, i] => i"        (\<open>(3UN _:_./ _)\<close> 10)
  "_INTER"    :: "[pttrn, i, i] => i"        (\<open>(3INT _:_./ _)\<close> 10)
  "_PROD"     :: "[pttrn, i, i] => i"        (\<open>(3PROD _:_./ _)\<close> 10)
  "_SUM"      :: "[pttrn, i, i] => i"        (\<open>(3SUM _:_./ _)\<close> 10)
  "_lam"      :: "[pttrn, i, i] => i"        (\<open>(3lam _:_./ _)\<close> 10)
  "_Tuple"    :: "[i, is] => i"              (\<open><(_,/ _)>\<close>)
  "_pattern"  :: "patterns => pttrn"         (\<open><_>\<close>)

subsection \<open>Substitution\<close>

(*Useful examples:  singletonI RS subst_elem,  subst_elem RSN (2,IntI) *)
lemma subst_elem: "[| b\<in>A;  a=b |] ==> a\<in>A"
by (erule ssubst, assumption)

subsection\<open>Bounded universal quantifier\<close>

lemma ballI [intro!]: "[| !!x. x\<in>A ==> P(x) |] ==> \<forall>x\<in>A. P(x)"
by (simp add: Ball_def)

lemmas strip = impI allI ballI

lemma bspec [dest?]: "[| \<forall>x\<in>A. P(x);  x: A |] ==> P(x)"
by (simp add: Ball_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_ballE [elim]:
    "[| \<forall>x\<in>A. P(x);  x\<notin>A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: Ball_def, blast)

lemma ballE: "[| \<forall>x\<in>A. P(x);  P(x) ==> Q;  x\<notin>A ==> Q |] ==> Q"
by blast

(*Used in the datatype package*)
lemma rev_bspec: "[| x: A;  \<forall>x\<in>A. P(x) |] ==> P(x)"
by (simp add: Ball_def)

(*Trival rewrite rule;   @{term"(\<forall>x\<in>A.P)<->P"} holds only if A is nonempty!*)
lemma ball_triv [simp]: "(\<forall>x\<in>A. P) <-> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
by (simp add: Ball_def)

(*Congruence rule for rewriting*)
lemma ball_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |] ==> (\<forall>x\<in>A. P(x)) <-> (\<forall>x\<in>A'. P'(x))"
by (simp add: Ball_def)

lemma atomize_ball:
    "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
  by (simp only: Ball_def atomize_all atomize_imp)

lemmas [symmetric, rulify] = atomize_ball
  and [symmetric, defn] = atomize_ball

subsection\<open>Bounded existential quantifier\<close>

lemma bexI [intro]: "[| P(x);  x: A |] ==> \<exists>x\<in>A. P(x)"
by (simp add: Bex_def, blast)

(*The best argument order when there is only one @{term"x\<in>A"}*)
lemma rev_bexI: "[| x\<in>A;  P(x) |] ==> \<exists>x\<in>A. P(x)"
by blast

(*Not of the general form for such rules. The existential quanitifer becomes universal. *)
lemma bexCI: "[| \<forall>x\<in>A. ~P(x) ==> P(a);  a: A |] ==> \<exists>x\<in>A. P(x)"
by blast

lemma bexE [elim!]: "[| \<exists>x\<in>A. P(x);  !!x. [| x\<in>A; P(x) |] ==> Q |] ==> Q"
by (simp add: Bex_def, blast)

(*We do not even have @{term"(\<exists>x\<in>A. True) <-> True"} unless @{term"A" is nonempty!!*)
lemma bex_triv [simp]: "(\<exists>x\<in>A. P) <-> ((\<exists>x. x\<in>A) & P)"
by (simp add: Bex_def)

lemma bex_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |]
     ==> (\<exists>x\<in>A. P(x)) <-> (\<exists>x\<in>A'. P'(x))"
by (simp add: Bex_def cong: conj_cong)

subsection\<open>Rules for subsets\<close>

lemma subsetI [intro!]:
    "(!!x. x\<in>A ==> x\<in>B) ==> A \<subseteq> B"
by (simp add: subset_def)

(*Rule in Modus Ponens style [was called subsetE] *)
lemma subsetD [elim]: "[| A \<subseteq> B;  c\<in>A |] ==> c\<in>B"
apply (unfold subset_def)
apply (erule bspec, assumption)
done

(*Classical elimination rule*)
lemma subsetCE [elim]:
    "[| A \<subseteq> B;  c\<notin>A ==> P;  c\<in>B ==> P |] ==> P"
by (simp add: subset_def, blast)

(*Sometimes useful with premises in this order*)
lemma rev_subsetD: "[| c\<in>A; A<=B |] ==> c\<in>B"
by blast

lemma contra_subsetD: "[| A \<subseteq> B; c \<notin> B |] ==> c \<notin> A"
by blast

lemma rev_contra_subsetD: "[| c \<notin> B;  A \<subseteq> B |] ==> c \<notin> A"
by blast

lemma subset_refl [simp]: "A \<subseteq> A"
by blast

lemma subset_trans: "[| A<=B;  B<=C |] ==> A<=C"
by blast

(*Useful for proving A<=B by rewriting in some cases*)
lemma subset_iff:
     "A<=B <-> (\<forall>x. x\<in>A \<longrightarrow> x\<in>B)"
apply (unfold subset_def Ball_def)
apply (rule iff_refl)
done

text\<open>For calculations\<close>
declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

subsection\<open>Rules for equality\<close>

(*Anti-symmetry of the subset relation*)
lemma equalityI [intro]: "[| A \<subseteq> B;  B \<subseteq> A |] ==> A = B"
by (rule extension [THEN iffD2], rule conjI)

lemma equality_iffI: "(!!x. x\<in>A <-> x\<in>B) ==> A = B"
by (rule equalityI, blast+)

lemmas equalityD1 = extension [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = extension [THEN iffD1, THEN conjunct2]

lemma equalityE: "[| A = B;  [| A<=B; B<=A |] ==> P |]  ==>  P"
by (blast dest: equalityD1 equalityD2)

lemma equalityCE:
    "[| A = B;  [| c\<in>A; c\<in>B |] ==> P;  [| c\<notin>A; c\<notin>B |] ==> P |]  ==>  P"
by (erule equalityE, blast)

lemma equality_iffD:
  "A = B ==> (!!x. x \<in> A <-> x \<in> B)"
  by auto

subsection\<open>Rules for Replace -- the derived form of replacement\<close>

lemma Replace_iff:
    "b \<in> {y. x\<in>A, P(x,y)}  <->  (\<exists>x\<in>A. P(x,b) & (\<forall>y. P(x,y) \<longrightarrow> y=b))"
apply (unfold Replace_def)
apply (rule replacement [THEN iff_trans], blast+)
done

(*Introduction; there must be a unique y such that P(x,y), namely y=b. *)
lemma ReplaceI [intro]:
    "[| P(x,b);  x: A;  !!y. P(x,y) ==> y=b |] ==>
     b \<in> {y. x\<in>A, P(x,y)}"
by (rule Replace_iff [THEN iffD2], blast)

(*Elimination; may asssume there is a unique y such that P(x,y), namely y=b. *)
lemma ReplaceE:
    "[| b \<in> {y. x\<in>A, P(x,y)};
        !!x. [| x: A;  P(x,b);  \<forall>y. P(x,y)\<longrightarrow>y=b |] ==> R
     |] ==> R"
by (rule Replace_iff [THEN iffD1, THEN bexE], simp+)

(*As above but without the (generally useless) 3rd assumption*)
lemma ReplaceE2 [elim!]:
    "[| b \<in> {y. x\<in>A, P(x,y)};
        !!x. [| x: A;  P(x,b) |] ==> R
     |] ==> R"
by (erule ReplaceE, blast)

lemma Replace_cong [cong]:
    "[| A=B;  !!x y. x\<in>B ==> P(x,y) <-> Q(x,y) |] ==>
     Replace(A,P) = Replace(B,Q)"
apply (rule equality_iffI)
apply (simp add: Replace_iff)
done

subsection\<open>Rules for RepFun\<close>

lemma RepFunI: "a \<in> A ==> f(a) \<in> {f(x). x\<in>A}"
by (simp add: RepFun_def Replace_iff, blast)

(*Useful for coinduction proofs*)
lemma RepFun_eqI [intro]: "[| b=f(a);  a \<in> A |] ==> b \<in> {f(x). x\<in>A}"
apply (erule ssubst)
apply (erule RepFunI)
done

lemma RepFunE [elim!]:
    "[| b \<in> {f(x). x\<in>A};
        !!x.[| x\<in>A;  b=f(x) |] ==> P |] ==>
     P"
by (simp add: RepFun_def Replace_iff, blast)

lemma RepFun_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> f(x)=g(x) |] ==> RepFun(A,f) = RepFun(B,g)"
by (simp add: RepFun_def)

lemma RepFun_iff [simp]: "b \<in> {f(x). x\<in>A} <-> (\<exists>x\<in>A. b=f(x))"
by (unfold Bex_def, blast)

lemma triv_RepFun [simp]: "{x. x\<in>A} = A"
by blast

subsection\<open>Rules for Collect -- forming a subset by separation\<close>

(*Separation is derivable from Replacement*)
lemma separation [simp]: "a \<in> {x\<in>A. P(x)} <-> a\<in>A & P(a)"
by (unfold Collect_def, blast)

lemma CollectI [intro!]: "[| a\<in>A;  P(a) |] ==> a \<in> {x\<in>A. P(x)}"
by simp

lemma CollectE [elim!]: "[| a \<in> {x\<in>A. P(x)};  [| a\<in>A; P(a) |] ==> R |] ==> R"
by simp

lemma CollectD1: "a \<in> {x\<in>A. P(x)} ==> a\<in>A"
by (erule CollectE, assumption)

lemma CollectD2: "a \<in> {x\<in>A. P(x)} ==> P(a)"
by (erule CollectE, assumption)

lemma Collect_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> P(x) <-> Q(x) |]
     ==> Collect(A, %x. P(x)) = Collect(B, %x. Q(x))"
by (simp add: Collect_def)

subsection\<open>Rules for Unions\<close>

declare Union_iff [simp]

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI [intro]: "[| B: C;  A: B |] ==> A: \<Union>(C)"
by (simp, blast)

lemma UnionE [elim!]: "[| A \<in> \<Union>(C);  !!B.[| A: B;  B: C |] ==> R |] ==> R"
by (simp, blast)

subsection\<open>Rules for Unions of families\<close>
(* @{term"\<Union>x\<in>A. B(x)"} abbreviates @{term"\<Union>({B(x). x\<in>A})"} *)

lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B(x)) <-> (\<exists>x\<in>A. b \<in> B(x))"
by (simp add: Bex_def, blast)

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "[| a: A;  b: B(a) |] ==> b: (\<Union>x\<in>A. B(x))"
by (simp, blast)

lemma UN_E [elim!]:
    "[| b \<in> (\<Union>x\<in>A. B(x));  !!x.[| x: A;  b: B(x) |] ==> R |] ==> R"
by blast

lemma UN_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Union>x\<in>A. C(x)) = (\<Union>x\<in>B. D(x))"
by simp

(*No "Addcongs [UN_cong]" because @{term\<Union>} is a combination of constants*)

(* UN_E appears before UnionE so that it is tried first, to avoid expensive
  calls to hyp_subst_tac.  Cannot include UN_I as it is unsafe: would enlarge
  the search space.*)

subsection\<open>Rules for the empty set\<close>

(*The set @{term"{x\<in>0. False}"} is empty; by foundation it equals 0
  See Suppes, page 21.*)
lemma not_mem_empty [simp]: "a \<notin> 0"
apply (cut_tac foundation)
apply (best dest: equalityD2)
done

lemmas emptyE [elim!] = not_mem_empty [THEN notE]

lemma empty_subsetI [simp]: "0 \<subseteq> A"
by blast

lemma equals0I: "[| !!y. y\<in>A ==> False |] ==> A=0"
by blast

lemma equals0D [dest]: "A=0 ==> a \<notin> A"
by blast

declare sym [THEN equals0D, dest]

lemma not_emptyI: "a\<in>A ==> A \<noteq> 0"
by blast

lemma not_emptyE:  "[| A \<noteq> 0;  !!x. x\<in>A ==> R |] ==> R"
by blast

subsection\<open>Rules for Inter\<close>

(*Not obviously useful for proving InterI, InterD, InterE*)
lemma Inter_iff: "A \<in> \<Inter>(C) <-> (\<forall>x\<in>C. A: x) & C\<noteq>0"
by (simp add: Inter_def Ball_def, blast)

(* Intersection is well-behaved only if the family is non-empty! *)
lemma InterI [intro!]:
    "[| !!x. x: C ==> A: x;  C\<noteq>0 |] ==> A \<in> \<Inter>(C)"
by (simp add: Inter_iff)

(*A "destruct" rule -- every B in C contains A as an element, but
  A\<in>B can hold when B\<in>C does not!  This rule is analogous to "spec". *)
lemma InterD [elim, Pure.elim]: "[| A \<in> \<Inter>(C);  B \<in> C |] ==> A \<in> B"
by (unfold Inter_def, blast)

(*"Classical" elimination rule -- does not require exhibiting @{term"B\<in>C"} *)
lemma InterE [elim]:
    "[| A \<in> \<Inter>(C);  B\<notin>C ==> R;  A\<in>B ==> R |] ==> R"
by (simp add: Inter_def, blast)

subsection\<open>Rules for Intersections of families\<close>

(* @{term"\<Inter>x\<in>A. B(x)"} abbreviates @{term"\<Inter>({B(x). x\<in>A})"} *)

lemma INT_iff: "b \<in> (\<Inter>x\<in>A. B(x)) <-> (\<forall>x\<in>A. b \<in> B(x)) & A\<noteq>0"
by (force simp add: Inter_def)

lemma INT_I: "[| !!x. x: A ==> b: B(x);  A\<noteq>0 |] ==> b: (\<Inter>x\<in>A. B(x))"
by blast

lemma INT_E: "[| b \<in> (\<Inter>x\<in>A. B(x));  a: A |] ==> b \<in> B(a)"
by blast

lemma INT_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Inter>x\<in>A. C(x)) = (\<Inter>x\<in>B. D(x))"
by simp

(*No "Addcongs [INT_cong]" because @{term\<Inter>} is a combination of constants*)

subsection\<open>Rules for Powersets\<close>

lemma PowI: "A \<subseteq> B ==> A \<in> Pow(B)"
by (erule Pow_iff [THEN iffD2])

lemma PowD: "A \<in> Pow(B)  ==>  A<=B"
by (erule Pow_iff [THEN iffD1])

declare Pow_iff [iff]

lemmas Pow_bottom = empty_subsetI [THEN PowI]    \<comment> \<open>\<^term>\<open>0 \<in> Pow(B)\<close>\<close>
lemmas Pow_top = subset_refl [THEN PowI]         \<comment> \<open>\<^term>\<open>A \<in> Pow(A)\<close>\<close>

subsection\<open>Cantor's Theorem: There is no surjection from a set to its powerset.\<close>

(*The search is undirected.  Allowing redundant introduction rules may
  make it diverge.  Variable b represents ANY map, such as
  (lam x\<in>A.b(x)): A->Pow(A). *)
lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
by (best elim!: equalityCE del: ReplaceI RepFun_eqI)

end