(*<*)
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
"Kuratowski:1922"}: 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
"Chagrov:1982"} that classifies topological spaces according to the
number of such operators they support.

Kuratowski's result, which is exposited in @{cite
"TheoremOfTheDay:2015"} and Chapter 7 of @{cite "Chamberland:2015"},
has already been treated in Mizar --- see @{cite
"BaginskaGrabowski:2003"} and @{cite "Grabowski:2004"}. 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 "GardnerJackson:2008"}.

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 intro!: le_trans[OF card_Diff1_le])

text\<open>

We show, using the following subset of \<open>\<real>\<close> (an
example taken from @{cite "Rusin:2001"}) 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 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
"GardnerJackson:2008"}, 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 "GardnerJackson:2008"}):

\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, hide_lams) 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, hide_lams) 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
(*>*)


section \<open>Separation of Roots: Sturm\<close>

text \<open>We adapt the existing theory on Sturm's theorem to work on rational numbers instead of real
  numbers. The reason is that we want to implement real numbers as real algebraic numbers with the
  help of Sturm's theorem to separate the roots. To this end, we just copy the definitions of
  of the algorithms w.r.t. Sturm and let them be executed on rational numbers. We then
  prove that corresponds to a homomorphism and therefore can transfer the existing soundness results.\<close>

theory Sturm_Rat
imports
  Sturm_Sequences.Sturm_Theorem
  Algebraic_Numbers_Prelim
begin

(* TODO: Move *)
lemma root_primitive_part [simp]:
  fixes p :: "'a :: {semiring_gcd, semiring_no_zero_divisors} poly"
  shows  "poly (primitive_part p) x = 0 \<longleftrightarrow> poly p x = 0"
proof(cases "p = 0")
  case True
  then show ?thesis by auto
next
  case False
  have "poly p x = content p * poly (primitive_part p) x"
    by (metis content_times_primitive_part poly_smult)
  also have "\<dots> = 0 \<longleftrightarrow> poly (primitive_part p) x = 0" by (simp add: False)
  finally show ?thesis by auto
qed

(*TODO: Move*)
lemma irreducible_primitive_part:
  assumes "irreducible p" and "degree p > 0"
  shows "primitive_part p = p"
  using irreducible_content[OF assms(1), unfolded primitive_iff_content_eq_1] assms(2)
  by (auto simp: primitive_part_def abs_poly_def)

subsection \<open>Interface for Separating Roots\<close>

text \<open>For a given rational polynomial, we need to know how many real roots are in a given closed interval,
  and how many real roots are in an interval $(-\infty,r]$.\<close>

datatype root_info = Root_Info (l_r: "rat \<Rightarrow> rat \<Rightarrow> nat") (number_root: "rat \<Rightarrow> nat")
hide_const (open) l_r
hide_const (open) number_root

definition count_roots_interval_sf :: "real poly \<Rightarrow> (real \<Rightarrow> real \<Rightarrow> nat) \<times> (real \<Rightarrow> nat)" where
  "count_roots_interval_sf p = (let ps = sturm_squarefree p
    in ((\<lambda> a b. sign_changes ps a - sign_changes ps b + (if poly p a = 0 then 1 else 0)),
       (\<lambda> a. sign_changes_neg_inf ps - sign_changes ps a)))"

definition count_roots_interval :: "real poly \<Rightarrow> (real \<Rightarrow> real \<Rightarrow> nat) \<times> (real \<Rightarrow> nat)" where
  "count_roots_interval p = (let ps = sturm p
    in ((\<lambda> a b. sign_changes ps a - sign_changes ps b + (if poly p a = 0 then 1 else 0)),
       (\<lambda> a. sign_changes_neg_inf ps - sign_changes ps a)))"

lemma count_roots_interval_iff: "square_free p \<Longrightarrow> count_roots_interval p = count_roots_interval_sf p"
  unfolding count_roots_interval_def count_roots_interval_sf_def sturm_squarefree_def
    square_free_iff_separable separable_def by (cases "p = 0", auto)

lemma count_roots_interval_sf: assumes p: "p \<noteq> 0"
  and cr: "count_roots_interval_sf p = (cr,nr)"
  shows "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}"
proof -
  have id: "a \<le> b \<Longrightarrow> { x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
    { x. a < x \<and> x \<le> b \<and> poly p x = 0} \<union> (if poly p a = 0 then {a} else {})"
    (is "_ \<Longrightarrow> _ = ?R \<union> ?S") using not_less by force
  have RS: "finite ?R" "finite ?S" "?R \<inter> ?S = {}"  using p by (auto simp: poly_roots_finite)
  show "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}" using cr unfolding arg_cong[OF id, of card] card_Un_disjoint[OF RS]
    count_roots_interval_sf_def count_roots_between_correct[symmetric]
    count_roots_below_correct[symmetric] count_roots_below_def
    count_roots_between_def Let_def using p by auto
qed

lemma count_roots_interval: assumes cr: "count_roots_interval p = (cr,nr)"
  and sf: "square_free p"
  shows "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}"
  using count_roots_interval_sf[OF _ cr[unfolded count_roots_interval_iff[OF sf]]]
    sf[unfolded square_free_def] by blast+

definition root_cond :: "int poly \<times> rat \<times> rat \<Rightarrow> real \<Rightarrow> bool" where
  "root_cond plr x = (case plr of (p,l,r) \<Rightarrow> of_rat l \<le> x \<and> x \<le> of_rat r \<and> ipoly p x = 0)"

definition root_info_cond :: "root_info \<Rightarrow> int poly \<Rightarrow> bool" where
  "root_info_cond ri p \<equiv> (\<forall> a b. a \<le> b \<longrightarrow> root_info.l_r ri a b = card {x. root_cond (p,a,b) x})
    \<and> (\<forall> a. root_info.number_root ri a = card {x. x \<le> real_of_rat a \<and> ipoly p x = 0})"

lemma root_info_condD: "root_info_cond ri p \<Longrightarrow> a \<le> b \<Longrightarrow> root_info.l_r ri a b = card {x. root_cond (p,a,b) x}"
  "root_info_cond ri p \<Longrightarrow> root_info.number_root ri a = card {x. x \<le> real_of_rat a \<and> ipoly p x = 0}"
  unfolding root_info_cond_def by auto

definition count_roots_interval_sf_rat :: "int poly \<Rightarrow> root_info" where
  "count_roots_interval_sf_rat  p = (let pp = real_of_int_poly p;
    (cr,nr) = count_roots_interval_sf pp
  in Root_Info (\<lambda> a b. cr (of_rat a) (of_rat b)) (\<lambda> a. nr (of_rat a)))"

definition count_roots_interval_rat :: "int poly \<Rightarrow> root_info" where
  [code del]: "count_roots_interval_rat  p = (let pp = real_of_int_poly p;
    (cr,nr) = count_roots_interval pp
  in Root_Info (\<lambda> a b. cr (of_rat a) (of_rat b)) (\<lambda> a. nr (of_rat a)))"

definition count_roots_rat :: "int poly \<Rightarrow> nat" where
  [code del]: "count_roots_rat  p = (count_roots (real_of_int_poly p))"

lemma count_roots_interval_sf_rat: assumes p: "p \<noteq> 0"
  shows "root_info_cond (count_roots_interval_sf_rat p) p"
proof -
  let ?p = "real_of_int_poly p"
  let ?r = real_of_rat
  let ?ri = "count_roots_interval_sf_rat p"
  from p have p: "?p \<noteq> 0" by auto
  obtain cr nr where cr: "count_roots_interval_sf ?p = (cr,nr)" by force
  have "?ri = Root_Info (\<lambda>a b. cr (?r a) (?r b)) (\<lambda>a. nr (?r a))"
    unfolding count_roots_interval_sf_rat_def Let_def cr by auto
  hence id: "root_info.l_r ?ri = (\<lambda>a b. cr (?r a) (?r b))" "root_info.number_root ?ri = (\<lambda>a. nr (?r a))"
    by auto
  note cr = count_roots_interval_sf[OF p cr]
  show ?thesis unfolding root_info_cond_def id
  proof (intro conjI impI allI)
    fix a
    show "nr (?r a) = card {x. x \<le> (?r a) \<and> ipoly p x = 0}"
      using cr(2)[of "?r a"] by simp
  next
    fix a b :: rat
    assume ab: "a \<le> b"
    from ab have ab: "?r a \<le> ?r b" by (simp add: of_rat_less_eq)
    from cr(1)[OF this] show "cr (?r a) (?r b) = card (Collect (root_cond (p, a, b)))"
      unfolding root_cond_def[abs_def] split by simp
  qed
qed

lemma of_rat_of_int_poly: "map_poly of_rat (of_int_poly p) = of_int_poly p"
  by (subst map_poly_map_poly, auto simp: o_def)

lemma square_free_of_int_poly: assumes "square_free p"
  shows "square_free (of_int_poly p :: 'a :: {field_gcd, field_char_0} poly)"
proof -
  have "square_free (map_poly of_rat (of_int_poly p) :: 'a poly)"
    unfolding of_rat_hom.square_free_map_poly by (rule square_free_int_rat[OF assms])
  thus ?thesis unfolding of_rat_of_int_poly .
qed

lemma count_roots_interval_rat: assumes sf: "square_free p"
  shows "root_info_cond (count_roots_interval_rat p) p"
proof -
  from sf have sf: "square_free (real_of_int_poly p)" by (rule square_free_of_int_poly)
  from sf have p: "p \<noteq> 0" unfolding square_free_def by auto
  show ?thesis
  using count_roots_interval_sf_rat[OF p]
  unfolding count_roots_interval_rat_def count_roots_interval_sf_rat_def
    Let_def count_roots_interval_iff[OF sf] .
qed

lemma count_roots_rat: "count_roots_rat p = card {x. ipoly p x = (0 :: real)}"
  unfolding count_roots_rat_def count_roots_correct ..

subsection \<open>Implementing Sturm on Rational Polynomials\<close>

function sturm_aux_rat where
"sturm_aux_rat (p :: rat poly) q =
    (if degree q = 0 then [p,q] else p # sturm_aux_rat q (-(p mod q)))"
  by (pat_completeness, simp_all)
termination by (relation "measure (degree \<circ> snd)",
                simp_all add: o_def degree_mod_less')

lemma sturm_aux_rat: "sturm_aux (real_of_rat_poly p) (real_of_rat_poly q) =
  map real_of_rat_poly (sturm_aux_rat p q)"
proof (induct p q rule: sturm_aux_rat.induct)
  case (1 p q)
  interpret map_poly_inj_idom_hom of_rat..
  note deg = of_int_hom.degree_map_poly_hom
  show ?case
    unfolding sturm_aux.simps[of "real_of_rat_poly p"] sturm_aux_rat.simps[of p]
    using 1 by (cases "degree q = 0"; simp add: hom_distribs)
qed

definition sturm_rat where "sturm_rat p = sturm_aux_rat p (pderiv p)"

lemma sturm_rat: "sturm (real_of_rat_poly p) = map real_of_rat_poly (sturm_rat p)"
  unfolding sturm_rat_def sturm_def
  apply (fold of_rat_hom.map_poly_pderiv)
  unfolding sturm_aux_rat..

definition poly_number_rootat :: "rat poly \<Rightarrow> rat" where
  "poly_number_rootat p \<equiv> sgn (coeff p (degree p))"

definition poly_neg_number_rootat :: "rat poly \<Rightarrow> rat" where
  "poly_neg_number_rootat p \<equiv> if even (degree p) then sgn (coeff p (degree p))
                                       else -sgn (coeff p (degree p))"

lemma poly_number_rootat: "poly_inf (real_of_rat_poly p) = real_of_rat (poly_number_rootat p)"
  unfolding poly_inf_def poly_number_rootat_def of_int_hom.degree_map_poly_hom of_rat_hom.coeff_map_poly_hom
    real_of_rat_sgn by simp

lemma poly_neg_number_rootat: "poly_neg_inf (real_of_rat_poly p) = real_of_rat (poly_neg_number_rootat p)"
  unfolding poly_neg_inf_def poly_neg_number_rootat_def of_int_hom.degree_map_poly_hom of_rat_hom.coeff_map_poly_hom
    real_of_rat_sgn by (simp add:hom_distribs)

definition sign_changes_rat where
"sign_changes_rat ps (x::rat) =
    length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map (\<lambda>p. sgn (poly p x)) ps))) - 1"

definition sign_changes_number_rootat where
  "sign_changes_number_rootat ps =
    length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map poly_number_rootat ps))) - 1"

definition sign_changes_neg_number_rootat where
  "sign_changes_neg_number_rootat ps =
      length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map poly_neg_number_rootat ps))) - 1"

lemma real_of_rat_list_neq: "list_neq (map real_of_rat xs) 0
  = map real_of_rat (list_neq xs 0)"
  by (induct xs, auto)

lemma real_of_rat_remdups_adj: "remdups_adj (map real_of_rat xs) = map real_of_rat (remdups_adj xs)"
  by (induct xs rule: remdups_adj.induct, auto)

lemma sign_changes_rat: "sign_changes (map real_of_rat_poly ps) (real_of_rat x)
  = sign_changes_rat ps x" (is "?l = ?r")
proof -
  define xs where "xs = list_neq (map (\<lambda>p. sgn (poly p x)) ps) 0"
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map (\<lambda>xa.  (sgn (poly xa x))) ps)) 0)) - 1"
    by (simp add: sign_changes_def real_of_rat_sgn o_def)
  also have "\<dots> = ?r" unfolding sign_changes_rat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma sign_changes_neg_number_rootat: "sign_changes_neg_inf (map real_of_rat_poly ps)
  =  sign_changes_neg_number_rootat ps" (is "?l = ?r")
proof -
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map poly_neg_number_rootat ps)) 0)) - 1"
    by (simp add: sign_changes_neg_inf_def o_def real_of_rat_sgn poly_neg_number_rootat)
  also have "\<dots> = ?r" unfolding sign_changes_neg_number_rootat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma sign_changes_number_rootat: "sign_changes_inf (map real_of_rat_poly ps)
  =  sign_changes_number_rootat ps" (is "?l = ?r")
proof -
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map poly_number_rootat ps)) 0)) - 1"
    unfolding sign_changes_inf_def
    unfolding map_map o_def real_of_rat_sgn poly_number_rootat ..
  also have "\<dots> = ?r" unfolding sign_changes_number_rootat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma count_roots_interval_rat_code[code]:
  "count_roots_interval_rat p = (let rp = map_poly rat_of_int p; ps = sturm_rat rp
    in Root_Info
      (\<lambda> a b. sign_changes_rat ps a - sign_changes_rat ps b + (if poly rp a = 0 then 1 else 0))
      (\<lambda> a. sign_changes_neg_number_rootat ps - sign_changes_rat ps a))"
  unfolding count_roots_interval_rat_def Let_def count_roots_interval_def split of_rat_of_int_poly[symmetric, where 'a = real]
    sturm_rat sign_changes_rat
    by (simp add: sign_changes_neg_number_rootat)

lemma count_roots_rat_code[code]:
  "count_roots_rat p = (let rp = map_poly rat_of_int p in if p = 0 then 0 else let ps = sturm_rat rp
    in sign_changes_neg_number_rootat ps - sign_changes_number_rootat ps)"
  unfolding count_roots_rat_def Let_def sturm_rat count_roots_code of_rat_of_int_poly[symmetric, where 'a = real]
    sign_changes_neg_number_rootat sign_changes_number_rootat
  by simp

hide_const (open) count_roots_interval_sf_rat

text \<open>Finally we provide an even more efficient implementation which
  avoids the "poly p x = 0" test, but it is restricted to irreducible polynomials.\<close>

definition root_info :: "int poly \<Rightarrow> root_info" where
  "root_info p = (if degree p = 1 then
    (let x = Rat.Fract (- coeff p 0) (coeff p 1)
     in Root_Info (\<lambda> l r. if l \<le> x \<and> x \<le> r then 1 else 0)  (\<lambda> b. if x \<le> b then 1 else 0)) else
    (let rp = map_poly rat_of_int p; ps = sturm_rat rp in
   Root_Info (\<lambda> a b. sign_changes_rat ps a - sign_changes_rat ps b)
      (\<lambda> a. sign_changes_neg_number_rootat ps - sign_changes_rat ps a)))"

lemma root_info:
  assumes irr: "irreducible p" and deg: "degree p > 0"
  shows "root_info_cond (root_info p) p"
proof (cases "degree p = 1")
  case deg: True
  from degree1_coeffs[OF this] obtain a b where p: "p = [:b,a:]" and "a \<noteq> 0" by auto
  from deg have "degree (real_of_int_poly p) = 1" by simp
  from roots1[OF this, unfolded roots1_def] p
  have id: "(ipoly p x = 0) = ((x :: real) = - b / a)" for x by auto
  have idd: "{x. real_of_rat aa \<le> x \<and>
                 x \<le> real_of_rat ba \<and> x = real_of_int (- b) / real_of_int a}
   = (if real_of_rat aa \<le> real_of_int (- b) / real_of_int a \<and>
                 real_of_int (- b) / real_of_int a \<le> real_of_rat ba then {real_of_int (- b) / real_of_int a} else {})"
    for aa ba by auto
  have iddd: "{x. x \<le> real_of_rat aa \<and> x = real_of_int (- b) / real_of_int a}
    = (if real_of_int (- b) / real_of_int a \<le> real_of_rat aa then {real_of_int (- b) / real_of_int a} else {})" for aa
    by auto
  have id4: "real_of_int x = real_of_rat (rat_of_int x)" for x by simp
  show ?thesis unfolding root_info_def deg unfolding root_info_cond_def id root_cond_def split
    unfolding p Fract_of_int_quotient Let_def idd iddd
    unfolding id4 of_rat_divide[symmetric] of_rat_less_eq by auto
next
  case False
  have irr_d: "irreducible\<^sub>d p" by (simp add: deg irr irreducible_connect_rev)
  from irreducible\<^sub>d_int_rat[OF this]
  have "irreducible (of_int_poly p :: rat poly)" by auto
  from irreducible_root_free[OF this]
  have idd: "(poly (of_int_poly p) a = 0) = False" for a :: rat
    unfolding root_free_def using False by auto
  have id: "root_info p = count_roots_interval_rat p"
    unfolding root_info_def if_False count_roots_interval_rat_code Let_def idd using False by auto
  show ?thesis unfolding id
    by (rule count_roots_interval_rat[OF irreducible\<^sub>d_square_free[OF irr_d]])
qed

end


section \<open>Properties of Magic Wands\<close>

theory WandProperties
  imports Distributivity
begin

context logic
begin

lemma modus_ponens:
  "Star P (Wand P Q), \<Delta> \<turnstile> Q"
proof (rule entailsI)
  fix \<sigma> s
  assume "\<sigma>, s, \<Delta> \<Turnstile> Star P (Wand P Q)"
  show "\<sigma>, s, \<Delta> \<Turnstile> Q"
    using \<open>\<sigma>, s, \<Delta> \<Turnstile> Star P (Wand P Q)\<close> commutative by force
qed

lemma transitivity:
  "Star (Wand A B) (Wand B C), \<Delta> \<turnstile> Wand A C"
proof (rule entailsI)
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Star (Wand A B) (Wand B C)"
  then obtain ab bc where "Some \<sigma> = ab \<oplus> bc" "ab, s, \<Delta> \<Turnstile> Wand A B" "bc, s, \<Delta> \<Turnstile> Wand B C"
    by auto
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand A C"
  proof (rule sat_wand)
    fix a \<sigma>'
    assume asm1: "a, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = \<sigma> \<oplus> a"
    then obtain aab where "Some aab = ab \<oplus> a"
      by (metis \<open>Some \<sigma> = ab \<oplus> bc\<close> asso3 commutative compatible_def option.exhaust_sel)
    then have "Some \<sigma>' = aab \<oplus> bc"
      by (metis \<open>Some \<sigma> = ab \<oplus> bc\<close> asm1 asso1 commutative)
    moreover have "aab, s, \<Delta> \<Turnstile> B"
      using \<open>Some aab = ab \<oplus> a\<close> \<open>ab, s, \<Delta> \<Turnstile> Wand A B\<close> asm1 by auto
    ultimately show "\<sigma>', s, \<Delta> \<Turnstile> C"
      using \<open>bc, s, \<Delta> \<Turnstile> Wand B C\<close> commutative by auto
  qed
qed

lemma currying1:
  "Wand (Star A B) C, \<Delta> \<turnstile> Wand A (Wand B C)"
proof (rule entailsI)
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Wand (Star A B) C"
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand A (Wand B C)"
  proof (rule sat_wand)
    fix a \<sigma>'
    assume asm1: "a, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = \<sigma> \<oplus> a"
    show "\<sigma>', s, \<Delta> \<Turnstile> Wand B C"
    proof (rule sat_wand)
      fix b \<sigma>''
      assume asm2: "b, s, \<Delta> \<Turnstile> B \<and> Some \<sigma>'' = \<sigma>' \<oplus> b"
      then obtain ab where "Some ab = a \<oplus> b"
        by (metis asm1 asso2 compatible_def option.collapse)
      then have "ab, s, \<Delta> \<Turnstile> Star A B"
        using asm1 asm2 by auto
      moreover have "Some \<sigma>'' = \<sigma> \<oplus> ab"
        by (metis \<open>Some ab = a \<oplus> b\<close> asm1 asm2 asso1)
      ultimately show "\<sigma>'', s, \<Delta> \<Turnstile> C"
        using asm0 sat.simps(3) by blast
    qed
  qed
qed

lemma currying2:
  "Wand A (Wand B C), \<Delta> \<turnstile> Wand (Star A B) C"
proof (rule entailsI)
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Wand A (Wand B C)"
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand (Star A B) C"
  proof (rule sat_wand)
    fix ab \<sigma>'
    assume asm1: "ab, s, \<Delta> \<Turnstile> Star A B \<and> Some \<sigma>' = \<sigma> \<oplus> ab"
    then obtain a b where "Some ab = a \<oplus> b" "a, s, \<Delta> \<Turnstile> A" "b, s, \<Delta> \<Turnstile> B"
      by auto
    then obtain bc where "Some bc = \<sigma> \<oplus> a"
      by (metis asm1 asso3 compatible_def option.exhaust_sel)
    then have "bc, s, \<Delta> \<Turnstile> Wand B C"
      using \<open>a, s, \<Delta> \<Turnstile> A\<close> asm0 by auto
    moreover have "Some \<sigma>' = bc \<oplus> b"
      by (metis \<open>Some ab = a \<oplus> b\<close> \<open>Some bc = \<sigma> \<oplus> a\<close> asm1 asso1)
    ultimately show "\<sigma>', s, \<Delta> \<Turnstile> C"
      using \<open>b, s, \<Delta> \<Turnstile> B\<close> sat.simps(3) by blast
  qed
qed

lemma distribution:
  "Star (Wand A B) C, \<Delta> \<turnstile> Wand A (Star B C)"
proof (rule entailsI)
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Star (Wand A B) C"
  then obtain ab c where "Some \<sigma> = ab \<oplus> c" "ab, s, \<Delta> \<Turnstile> Wand A B" "c, s, \<Delta> \<Turnstile> C"
    by auto
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand A (Star B C)"
  proof (rule sat_wand)
    fix a \<sigma>'
    assume asm1: "a, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = \<sigma> \<oplus> a"
    then obtain b where "Some b = ab \<oplus> a"
      by (metis \<open>Some \<sigma> = ab \<oplus> c\<close> asso3 commutative compatible_def option.exhaust_sel)
    then have "b, s, \<Delta> \<Turnstile> B"
      using \<open>ab, s, \<Delta> \<Turnstile> Wand A B\<close> asm1 by force
    moreover have "Some \<sigma>' = b \<oplus> c"
      by (metis \<open>Some \<sigma> = ab \<oplus> c\<close> \<open>Some b = ab \<oplus> a\<close> asm1 asso1 commutative)
    ultimately show "\<sigma>', s, \<Delta> \<Turnstile> Star B C"
      using \<open>c, s, \<Delta> \<Turnstile> C\<close> sat.simps(2) by blast
  qed
qed

lemma adjunct1:
  assumes "A, \<Delta> \<turnstile> Wand B C"
  shows "Star A B, \<Delta> \<turnstile> C"
proof (rule entailsI)
  fix \<sigma> s
  assume "\<sigma>, s, \<Delta> \<Turnstile> Star A B"
  then show "\<sigma>, s, \<Delta> \<Turnstile> C"
    using assms entails_def by force
qed

lemma adjunct2:
  assumes "Star A B, \<Delta> \<turnstile> C"
  shows "A, \<Delta> \<turnstile> Wand B C"
proof (rule entailsI)
  fix \<sigma> s
  assume "\<sigma>, s, \<Delta> \<Turnstile> A"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Wand B C"
    by (meson assms entails_def sat.simps(2) sat_wand)
qed

end

end


(*  Title:       Counterexample-Reducing Inference Systems and the Standard Redundancy Criterion
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017, 2020
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
*)

section \<open>Counterexample-Reducing Inference Systems and the Standard Redundancy Criterion\<close>

theory Standard_Redundancy_Criterion
  imports
    Saturation_Framework.Calculus
    "HOL-Library.Multiset_Order"
begin

text \<open>
The standard redundancy criterion can be defined uniformly for all inference systems equipped with
a compact consequence relation. The essence of the refutational completeness argument can be carried
out abstractly for counterexample-reducing inference systems, which enjoy a ``smallest
counterexample'' property. This material is partly based on Section 4.2 of Bachmair and Ganzinger's
\emph{Handbook} chapter, but adapted to the saturation framework of Waldmann et al.
\<close>

subsection \<open>Counterexample-Reducing Inference Systems\<close>

abbreviation main_prem_of :: "'f inference \<Rightarrow> 'f" where
  "main_prem_of \<iota> \<equiv> last (prems_of \<iota>)"

abbreviation side_prems_of :: "'f inference \<Rightarrow> 'f list" where
  "side_prems_of \<iota> \<equiv> butlast (prems_of \<iota>)"

lemma set_prems_of:
  "set (prems_of \<iota>) = (if prems_of \<iota> = [] then {} else {main_prem_of \<iota>} \<union> set (side_prems_of \<iota>))"
  by clarsimp (metis Un_insert_right append_Nil2 append_butlast_last_id list.set(2) set_append)

locale counterex_reducing_inference_system = inference_system Inf + consequence_relation
  for Inf :: "('f :: wellorder) inference set" +
  fixes I_of :: "'f set \<Rightarrow> 'f set"
  assumes Inf_counterex_reducing:
    "N \<inter> Bot = {} \<Longrightarrow> D \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> {D} \<Longrightarrow> (\<And>C. C \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> {C} \<Longrightarrow> D \<le> C) \<Longrightarrow>
     \<exists>\<iota> \<in> Inf. prems_of \<iota> \<noteq> [] \<and> main_prem_of \<iota> = D \<and> set (side_prems_of \<iota>) \<subseteq> N \<and> I_of N
         \<Turnstile> set (side_prems_of \<iota>)
       \<and> \<not> I_of N \<Turnstile> {concl_of \<iota>} \<and> concl_of \<iota> < D"
begin

lemma ex_min_counterex:
  fixes N :: "('f :: wellorder) set"
  assumes "\<not> I \<Turnstile> N"
  shows "\<exists>C \<in> N. \<not> I \<Turnstile> {C} \<and> (\<forall>D \<in> N. D < C \<longrightarrow> I \<Turnstile> {D})"
proof -
  obtain C where
    "C \<in> N" and "\<not> I \<Turnstile> {C}"
    using assms all_formulas_entailed by blast
  then have c_in: "C \<in> {C \<in> N. \<not> I \<Turnstile> {C}}"
    by blast
  show ?thesis
    using wf_eq_minimal[THEN iffD1, rule_format, OF wellorder_class.wf c_in] by blast
qed

end

text \<open>
Theorem 4.4 (generalizes Theorems 3.9 and 3.16):
\<close>

locale counterex_reducing_inference_system_with_trivial_redundancy =
  counterex_reducing_inference_system _ _ Inf + calculus _ Inf _ "\<lambda>_. {}" "\<lambda>_. {}"
  for Inf :: "('f :: wellorder) inference set"
begin

theorem saturated_model:
  assumes
    satur: "saturated N" and
    bot_ni_n: "N \<inter> Bot = {}"
  shows "I_of N \<Turnstile> N"
proof (rule ccontr)
  assume "\<not> I_of N \<Turnstile> N"
  then obtain D :: 'f where
    d_in_n: "D \<in> N" and
    d_cex: "\<not> I_of N \<Turnstile> {D}" and
    d_min: "\<And>C. C \<in> N \<Longrightarrow> C < D \<Longrightarrow> I_of N \<Turnstile> {C}"
    by (meson ex_min_counterex)
  then obtain \<iota> :: "'f inference" where
    \<iota>_inf: "\<iota> \<in> Inf" and
    concl_cex: "\<not> I_of N \<Turnstile> {concl_of \<iota>}" and
    concl_lt_d: "concl_of \<iota> < D"
    using Inf_counterex_reducing[OF bot_ni_n] by force
  have "concl_of \<iota> \<in> N"
    using \<iota>_inf Red_I_of_Inf_to_N by blast
  then show False
    using concl_cex concl_lt_d d_min by blast
qed

text \<open>
An abstract version of Corollary 3.10 does not hold without some conditions, according to Nitpick:
\<close>

corollary saturated_complete:
  assumes
    satur: "saturated N" and
    unsat: "N \<Turnstile> Bot"
  shows "N \<inter> Bot \<noteq> {}"
  oops

end

subsection \<open>Compactness\<close>

locale concl_compact_consequence_relation = consequence_relation +
  assumes
    entails_concl_compact: "finite EE \<Longrightarrow> CC \<Turnstile> EE \<Longrightarrow> \<exists>CC' \<subseteq> CC. finite CC' \<and> CC' \<Turnstile> EE"
begin

lemma entails_concl_compact_union:
  assumes
    fin_e: "finite EE" and
    cd_ent: "CC \<union> DD \<Turnstile> EE"
  shows "\<exists>CC' \<subseteq> CC. finite CC' \<and> CC' \<union> DD \<Turnstile> EE"
proof -
  obtain CCDD' where
    cd1_fin: "finite CCDD'" and
    cd1_sub: "CCDD' \<subseteq> CC \<union> DD" and
    cd1_ent: "CCDD' \<Turnstile> EE"
    using entails_concl_compact[OF fin_e cd_ent] by blast

  define CC' where
    "CC' = CCDD' - DD"
  have "CC' \<subseteq> CC"
    unfolding CC'_def using cd1_sub by blast
  moreover have "finite CC'"
    unfolding CC'_def using cd1_fin by blast
  moreover have "CC' \<union> DD \<Turnstile> EE"
    unfolding CC'_def using cd1_ent
    by (metis Un_Diff_cancel2 Un_upper1 entails_trans subset_entailed)
  ultimately show ?thesis
    by blast
qed

end

subsection \<open>The Standard Redundancy Criterion\<close>

locale calculus_with_standard_redundancy =
  inference_system Inf + concl_compact_consequence_relation Bot entails
  for
    Inf :: "('f :: wellorder) inference set" and
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) +
  assumes
    Inf_has_prem: "\<iota> \<in> Inf \<Longrightarrow> prems_of \<iota> \<noteq> []" and
    Inf_reductive: "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> < main_prem_of \<iota>"
begin

definition redundant_infer :: "'f set \<Rightarrow> 'f inference \<Rightarrow> bool" where
  "redundant_infer N \<iota> \<longleftrightarrow>
   (\<exists>DD \<subseteq> N. DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>} \<and> (\<forall>D \<in> DD. D < main_prem_of \<iota>))"

definition Red_I :: "'f set \<Rightarrow> 'f inference set" where
  "Red_I N = {\<iota> \<in> Inf. redundant_infer N \<iota>}"

definition Red_F :: "'f set \<Rightarrow> 'f set" where
  "Red_F N = {C. \<exists>DD \<subseteq> N. DD \<Turnstile> {C} \<and> (\<forall>D \<in> DD. D < C)}"

text \<open>
The following results correspond to Lemma 4.5. The lemma \<open>wlog_non_Red_F\<close> generalizes the core of
the argument.
\<close>

lemma Red_F_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_F N \<subseteq> Red_F N'"
  unfolding Red_F_def by fast

lemma wlog_non_Red_F:
  assumes
    dd0_sub: "DD0 \<subseteq> N" and
    dd0_ent: "DD0 \<union> CC \<Turnstile> {E}" and
    dd0_lt: "\<forall>D' \<in> DD0. D' < D"
  shows "\<exists>DD \<subseteq> N - Red_F N. DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in> DD. D' < D)"
proof -
  obtain DD1 where
    "finite DD1" and
    "DD1 \<subseteq> N" and
    "DD1 \<union> CC \<Turnstile> {E}" and
    "\<forall>D' \<in> DD1. D' < D"
    using entails_concl_compact_union[OF _ dd0_ent] dd0_lt dd0_sub by fast
  then obtain DD2 :: "'f multiset" where
    "set_mset DD2 \<subseteq> N \<and> set_mset DD2 \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in> set_mset DD2. D' < D)"
    using assms by (metis finite_set_mset_mset_set)
  hence dd2: "DD2 \<in> {DD. set_mset DD \<subseteq> N \<and> set_mset DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in> set_mset DD. D' < D)}"
    by blast
  have "\<exists>DD. set_mset DD \<subseteq> N \<and> set_mset DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in># DD. D' < D) \<and>
    (\<forall>DDa. set_mset DDa \<subseteq> N \<and> set_mset DDa \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in># DDa. D' < D) \<longrightarrow> DD \<le> DDa)"
    using wf_eq_minimal[THEN iffD1, rule_format, OF wf_less_multiset, OF dd2]
    unfolding not_le[symmetric] by blast
  then obtain DD :: "'f multiset" where
    dd_subs_n: "set_mset DD \<subseteq> N" and
    ddcc_ent_e: "set_mset DD \<union> CC \<Turnstile> {E}" and
    dd_lt_d: "\<forall>D' \<in># DD. D' < D" and
    d_min: "\<forall>DDa. set_mset DDa \<subseteq> N \<and> set_mset DDa \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in># DDa. D' < D) \<longrightarrow> DD \<le> DDa"
    by blast

  have "\<forall>Da \<in># DD. Da \<notin> Red_F N"
  proof clarify
    fix Da
    assume
      da_in_dd: "Da \<in># DD" and
      da_rf: "Da \<in> Red_F N"

    obtain DDa0 where
      "DDa0 \<subseteq> N"
      "finite DDa0"
      "DDa0 \<Turnstile> {Da}"
      "\<forall>D \<in> DDa0. D < Da"
      using da_rf unfolding Red_F_def mem_Collect_eq
      by (smt entails_concl_compact finite.emptyI finite.insertI subset_iff)
    then obtain DDa1 :: "'f multiset" where
      dda1_subs_n: "set_mset DDa1 \<subseteq> N" and
      dda1_ent_da: "set_mset DDa1 \<Turnstile> {Da}" and
      dda1_lt_da: "\<forall>D' \<in># DDa1. D' < Da"
      by (metis finite_set_mset_mset_set)

    define DDa :: "'f multiset" where
      "DDa = DD - {#Da#} + DDa1"

    have "set_mset DDa \<subseteq> N"
      unfolding DDa_def using dd_subs_n dda1_subs_n
      by (meson contra_subsetD in_diffD subsetI union_iff)
    moreover have "set_mset DDa \<union> CC \<Turnstile> {E}"
      by (rule entails_trans_strong[of _ "{Da}"],
          metis DDa_def dda1_ent_da entail_union entails_trans order_refl set_mset_union
            subset_entailed,
          smt DDa_def da_in_dd ddcc_ent_e entails_trans insert_DiffM2 set_mset_add_mset_insert
            set_mset_empty set_mset_union subset_entailed sup_assoc sup_commute sup_ge1)
    moreover have "\<forall>D' \<in># DDa. D' < D"
      using dd_lt_d dda1_lt_da da_in_dd unfolding DDa_def
      by (metis insert_DiffM2 order.strict_trans union_iff)
    moreover have "DDa < DD"
      unfolding DDa_def
      by (meson da_in_dd dda1_lt_da mset_lt_single_right_iff single_subset_iff union_le_diff_plus)
    ultimately show False
      using d_min unfolding less_eq_multiset_def by (auto intro!: antisym)
  qed
  then show ?thesis
    using dd_subs_n ddcc_ent_e dd_lt_d by blast
qed

lemma Red_F_imp_ex_non_Red_F:
  assumes c_in: "C \<in> Red_F N"
  shows "\<exists>CC \<subseteq> N - Red_F N. CC \<Turnstile> {C} \<and> (\<forall>C' \<in> CC. C' < C)"
proof -
  obtain DD :: "'f set" where
    dd_sub: "DD \<subseteq> N" and
    dd_ent: "DD \<Turnstile> {C}" and
    dd_lt: "\<forall>D \<in> DD. D < C"
    using c_in[unfolded Red_F_def] by fast
  show ?thesis
    by (rule wlog_non_Red_F[of "DD" N "{}" C C, simplified, OF dd_sub dd_ent dd_lt])
qed

lemma Red_F_subs_Red_F_diff_Red_F: "Red_F N \<subseteq> Red_F (N - Red_F N)"
proof
  fix C
  assume c_rf: "C \<in> Red_F N"
  then obtain CC :: "'f set" where
    cc_subs: "CC \<subseteq> N - Red_F N" and
    cc_ent_c: "CC \<Turnstile> {C}" and
    cc_lt_c: "\<forall>C' \<in> CC. C' < C"
    using Red_F_imp_ex_non_Red_F[of C N] by blast
  have "\<forall>D \<in> CC. D \<notin> Red_F N"
    using cc_subs by fast
  then have cc_nr:
    "\<forall>C \<in> CC. \<forall>DD \<subseteq> N. DD \<Turnstile> {C} \<longrightarrow> (\<exists>D \<in> DD. \<not> D < C)"
    unfolding Red_F_def by simp
  have "CC \<subseteq> N"
    using cc_subs by auto
  then have "CC \<subseteq> N - {C. \<exists>DD \<subseteq> N. DD \<Turnstile> {C} \<and> (\<forall>D \<in> DD. D < C)}"
    using cc_nr by blast
  then show "C \<in> Red_F (N - Red_F N)"
    using cc_ent_c cc_lt_c unfolding Red_F_def by blast
qed

lemma Red_F_eq_Red_F_diff_Red_F: "Red_F N = Red_F (N - Red_F N)"
  by (simp add: Red_F_of_subset Red_F_subs_Red_F_diff_Red_F set_eq_subset)

text \<open>
The following results correspond to Lemma 4.6. It also uses \<open>wlog_non_Red_F\<close>.
\<close>

lemma Red_I_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_I N \<subseteq> Red_I N'"
  unfolding Red_I_def redundant_infer_def by auto

lemma Red_I_subs_Red_I_diff_Red_F: "Red_I N \<subseteq> Red_I (N - Red_F N)"
proof
  fix \<iota>
  assume \<iota>_ri: "\<iota> \<in> Red_I N"
  define CC :: "'f set" where
    "CC = set (side_prems_of \<iota>)"
  define D :: 'f where
    "D = main_prem_of \<iota>"
  define E :: 'f where
    "E = concl_of \<iota>"
  obtain DD :: "'f set" where
    dd_sub: "DD \<subseteq> N" and
    dd_ent: "DD \<union> CC \<Turnstile> {E}" and
    dd_lt_d: "\<forall>C \<in> DD. C < D"
    using \<iota>_ri unfolding Red_I_def redundant_infer_def CC_def D_def E_def by blast
  obtain DDa :: "'f set" where
    "DDa \<subseteq> N - Red_F N" and "DDa \<union> CC \<Turnstile> {E}" and "\<forall>D' \<in> DDa. D' < D"
    using wlog_non_Red_F[OF dd_sub dd_ent dd_lt_d] by blast
  then show "\<iota> \<in> Red_I (N - Red_F N)"
    using \<iota>_ri unfolding Red_I_def redundant_infer_def CC_def D_def E_def by blast
qed

lemma Red_I_eq_Red_I_diff_Red_F: "Red_I N = Red_I (N - Red_F N)"
  by (metis Diff_subset Red_I_of_subset Red_I_subs_Red_I_diff_Red_F subset_antisym)

lemma Red_I_to_Inf: "Red_I N \<subseteq> Inf"
  unfolding Red_I_def by blast

lemma Red_F_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_F N \<subseteq> Red_F (N - N')"
  by (metis Diff_mono Red_F_eq_Red_F_diff_Red_F Red_F_of_subset order_refl)

lemma Red_I_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_I N \<subseteq> Red_I (N - N')"
  by (metis Diff_mono Red_I_eq_Red_I_diff_Red_F Red_I_of_subset order_refl)

lemma Red_F_model: "M \<Turnstile> N - Red_F N \<Longrightarrow> M \<Turnstile> N"
  by (metis (no_types) DiffI Red_F_imp_ex_non_Red_F entail_set_all_formulas entails_trans
      subset_entailed)

lemma Red_F_Bot: "B \<in> Bot \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> N - Red_F N \<Turnstile> {B}"
  using Red_F_model entails_trans subset_entailed by blast

lemma Red_I_of_Inf_to_N:
  assumes
    in_\<iota>: "\<iota> \<in> Inf" and
    concl_in: "concl_of \<iota> \<in> N"
  shows "\<iota> \<in> Red_I N"
proof -
  have "concl_of \<iota> \<in> N \<Longrightarrow> redundant_infer N \<iota>"
    unfolding redundant_infer_def
    by (metis (no_types) Inf_reductive empty_iff empty_subsetI entail_union in_\<iota> insert_iff
        insert_subset subset_entailed subset_refl)
  then show "\<iota> \<in> Red_I N"
    by (simp add: Red_I_def concl_in in_\<iota>)
qed

text \<open>
The following corresponds to Theorems 4.7 and 4.8:
\<close>

sublocale calculus Bot Inf "(\<Turnstile>)" Red_I Red_F
  by (unfold_locales, fact Red_I_to_Inf, fact Red_F_Bot, fact Red_F_of_subset,
      fact Red_I_of_subset, fact Red_F_of_Red_F_subset, fact Red_I_of_Red_F_subset,
      fact Red_I_of_Inf_to_N)

end

locale counterex_reducing_calculus_with_standard_redundancy =
  calculus_with_standard_redundancy Inf + counterex_reducing_inference_system _ _ Inf
  for Inf :: "('f :: wellorder) inference set"
begin

subsection \<open>Refutational Completeness\<close>

text \<open>
The following result loosely corresponds to Theorem 4.9.
\<close>

lemma saturated_model:
  assumes
    satur: "saturated N" and
    bot_ni_n: "N \<inter> Bot = {}"
  shows "I_of N \<Turnstile> N"
proof (rule ccontr)
  assume "\<not> I_of N \<Turnstile> N"
  then obtain D :: 'f where
    d_in_n: "D \<in> N" and
    d_cex: "\<not> I_of N \<Turnstile> {D}" and
    d_min: "\<And>C. C \<in> N \<Longrightarrow> C < D \<Longrightarrow> I_of N \<Turnstile> {C}"
    using ex_min_counterex by blast
  then obtain \<iota> :: "'f inference" where
    \<iota>_in: "\<iota> \<in> Inf" and
    \<iota>_mprem: "D = main_prem_of \<iota>" and
    sprem_subs_n: "set (side_prems_of \<iota>) \<subseteq> N" and
    sprem_true: "I_of N \<Turnstile> set (side_prems_of \<iota>)" and
    concl_cex: "\<not> I_of N \<Turnstile> {concl_of \<iota>}" and
    concl_lt_d: "concl_of \<iota> < D"
    using Inf_counterex_reducing[OF bot_ni_n] not_le by metis
  have "\<iota> \<in> Red_I N"
    by (rule subsetD[OF satur[unfolded saturated_def Inf_from_def]],
        simp add: \<iota>_in set_prems_of Inf_has_prem)
      (use \<iota>_mprem d_in_n sprem_subs_n  in blast)
  then have "\<iota> \<in> Red_I N"
    using Red_I_without_red_F by blast
  then obtain DD :: "'f set" where
    dd_subs_n: "DD \<subseteq> N" and
    dd_cc_ent_d: "DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>}" and
    dd_lt_d: "\<forall>C \<in> DD. C < D"
    unfolding Red_I_def redundant_infer_def \<iota>_mprem by blast
  from dd_subs_n dd_lt_d have "I_of N \<Turnstile> DD"
    using d_min by (meson ex_min_counterex subset_iff)
  then have "I_of N \<Turnstile> {concl_of \<iota>}"
    using entails_trans dd_cc_ent_d entail_union sprem_true by blast
  then show False
    using concl_cex by auto
qed

text \<open>
A more faithful abstract version of Theorem 4.9 does not hold without some conditions, according to
Nitpick:
\<close>

corollary saturated_complete:
  assumes
    satur: "saturated N" and
    unsat: "N \<Turnstile> Bot"
  shows "N \<inter> Bot \<noteq> {}"
  oops

end

end