theory Generated_Boolean_Algebra
  imports Main
begin

(**************************************************************************************************)
(**************************************************************************************************)
section\<open>Generated Boolean Algebras of Sets\<close>
(**************************************************************************************************)
(**************************************************************************************************)

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>Definitions and Basic Lemmas\<close>
(**************************************************************************************************)
(**************************************************************************************************)
lemma equalityI':
  assumes "\<And>x. x \<in> A \<Longrightarrow> x \<in> B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> x \<in> A"
  shows "A = B"
  using assms by blast

lemma equalityI'':
  assumes "\<And>x. A x \<Longrightarrow> B x"
  assumes "\<And>x. B x \<Longrightarrow> A x"
  shows "{x. A x} = {x. B x}"
  using assms by blast

lemma SomeE:
  assumes "a = (SOME x. P x)"
  assumes "P c"
  shows "P a"
  using assms  by (meson verit_sko_ex)

lemma SomeE':
  assumes "a = (SOME x. P x)"
  assumes "\<exists> x. P x"
  shows "P a"
  using assms  by (meson verit_sko_ex)

section\<open>Basic notions about boolean algebras over a set \<open>S\<close>, generated by a set of generators \<open>B\<close>\<close>

text\<open>Note that the generators \<open>B\<close> need not be subsets of the set \<open>S\<close>\<close>

inductive_set gen_boolean_algebra
  for S and B  where
    universe: "S \<in> gen_boolean_algebra S B"
  | generator:  "A \<in> B \<Longrightarrow> A \<inter> S \<in> gen_boolean_algebra S B"
  | union:      "\<lbrakk> A \<in> gen_boolean_algebra S B; C \<in> gen_boolean_algebra S B\<rbrakk> \<Longrightarrow> A \<union> C \<in> gen_boolean_algebra S B"
  | complement: "A \<in> gen_boolean_algebra S B \<Longrightarrow> S - A \<in> gen_boolean_algebra S B"

lemma gen_boolean_algebra_subset:
  shows "A \<in> gen_boolean_algebra S B \<Longrightarrow> A \<subseteq> S"
  apply(induction A rule: gen_boolean_algebra.induct)
  apply blast
  apply blast
  apply blast
  by blast

lemma gen_boolean_algebra_intersect:
  assumes "A \<in> gen_boolean_algebra S B"
  assumes "C \<in> gen_boolean_algebra S B"
  shows "A \<inter> C \<in> gen_boolean_algebra S B"
proof-
  have 0: "S - A \<in> gen_boolean_algebra S B"
    using assms(1) gen_boolean_algebra.complement by blast
  have 1: "S - C \<in> gen_boolean_algebra S B"
    using assms(2) gen_boolean_algebra.complement by blast
  have 2: "(S - A) \<union> (S - C) \<in> gen_boolean_algebra S B"
    using "0" "1" gen_boolean_algebra.union by blast
  have "S - (A \<inter> C) \<in> gen_boolean_algebra S B"
    by (simp add: 2 Diff_Int)
  then have 3: "S - (S - (A \<inter> C)) \<in> gen_boolean_algebra S B"
    using gen_boolean_algebra.complement
    by blast
  have "A \<inter> C \<subseteq> S"
    using assms(1) gen_boolean_algebra_subset
    by blast
  then show ?thesis
    using 3
    by (metis "0" Diff_partition Un_subset_iff assms(1) double_diff gen_boolean_algebra_subset)
qed

lemma gen_boolean_algebra_diff:
  assumes "A \<in> gen_boolean_algebra S B"
  assumes "C \<in> gen_boolean_algebra S B"
  shows "A -  C \<in> gen_boolean_algebra S B"
proof-
  have "A - C = A \<inter> (S - C)"
    by (metis Int_Diff assms(1) gen_boolean_algebra_subset inf_absorb1)
  then show ?thesis
    by (metis assms(1) assms(2) gen_boolean_algebra.complement gen_boolean_algebra_intersect)
qed

lemma gen_boolean_algebra_diff_eq:
  assumes "A \<in> gen_boolean_algebra S B"
  assumes "C \<in> gen_boolean_algebra S B"
  shows "A -  C = A \<inter> (S - C)"
  by (metis Int_Diff assms(1) gen_boolean_algebra_subset inf_absorb1)

lemma gen_boolean_algebra_finite_union:
  assumes "\<And>a. a \<in> A \<Longrightarrow> a \<in> gen_boolean_algebra S B"
  assumes "finite A"
  shows "\<Union>A \<in> gen_boolean_algebra S B"
proof-
  have "(\<forall>a \<in> A. a \<in> gen_boolean_algebra S B) \<longrightarrow> \<Union>A \<in> gen_boolean_algebra S B"
  apply(rule finite.induct[of A])
  apply (simp add: assms(2); fail)
   apply (metis DiffE Union_empty ex_in_conv  gen_boolean_algebra.simps)
  by (metis Union_insert gen_boolean_algebra.simps insert_iff)
  then show ?thesis using assms by blast
qed

lemma gen_boolean_algebra_finite_intersection:
  assumes "\<And>a. a \<in> A \<Longrightarrow> a \<in> gen_boolean_algebra S B"
  assumes "finite A"
  assumes "A \<noteq> {}"
  shows "\<Inter>A \<in> gen_boolean_algebra S B"
proof-
  have "(\<forall>a \<in> A. a \<in> gen_boolean_algebra S B) \<and> A \<noteq> {} \<longrightarrow> \<Inter>A \<in> gen_boolean_algebra S B"
  apply(rule finite.induct[of A])
  apply (simp add: assms(2))
    apply force
  using gen_boolean_algebra_intersect by auto
  then show ?thesis using assms by blast
qed

lemma gen_boolean_algebra_generators:
  assumes "\<And>b. b \<in> B \<Longrightarrow> b \<subseteq> S"
  assumes "b \<in> B"
  shows "b \<in> gen_boolean_algebra S B"
  unfolding gen_boolean_algebra.simps[of b] using assms(1)[of b] assms(2)  by blast

lemma gen_boolean_algebra_generator_subset:
  assumes "A \<in> gen_boolean_algebra S As"
  assumes "As \<subseteq> Bs"
  shows "A \<in> gen_boolean_algebra S Bs"
  apply(rule gen_boolean_algebra.induct[of A S As])
  using assms(1) apply blast
  apply (simp add: gen_boolean_algebra.intros(1); fail)
  apply (meson Set.basic_monos(7) assms(2) gen_boolean_algebra.intros(2))
  using gen_boolean_algebra.intros(3) apply blast
  using gen_boolean_algebra.intros(4) by blast

lemma gen_boolean_algebra_generators_union:
  assumes "A \<in> gen_boolean_algebra S As"
  assumes "C \<in> gen_boolean_algebra S Cs"
  shows "A \<union> C \<in> gen_boolean_algebra S (As \<union> Cs)"
  apply(rule gen_boolean_algebra.induct[of C S Cs])
  using assms apply blast
apply(rule gen_boolean_algebra.union)
      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
     apply(rule gen_boolean_algebra.universe)
    apply(rule gen_boolean_algebra.union)
      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
    apply(rule gen_boolean_algebra.generator, blast)
    apply(rule gen_boolean_algebra.union)
      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
    apply(rule gen_boolean_algebra.union)
            apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs], blast, blast)
            apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs], blast, blast)
    apply(rule gen_boolean_algebra.union)
      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
      apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs])
   apply(rule gen_boolean_algebra_diff)
     apply(rule gen_boolean_algebra.universe)
  apply blast
by blast

lemma gen_boolean_algebra_finite_gen_wits:
  assumes "A \<in> gen_boolean_algebra S B"
  shows "\<exists> Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs"
proof(rule gen_boolean_algebra.induct[of A S B])
  show " A \<in> gen_boolean_algebra S B"
    using assms by blast
  show "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> S \<in> gen_boolean_algebra S Bs"
    using gen_boolean_algebra.universe[of S "{}"]
    by blast
  show "\<And>A. A \<in> B \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<inter> S \<in> gen_boolean_algebra S Bs"
  proof- fix A assume A: "A \<in> B"
    have 0: "{A} \<subseteq> B"
      using A by blast
    show "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<inter> S \<in> gen_boolean_algebra S Bs"
      using gen_boolean_algebra.generator[of A "{A}" S] 0
      by (meson finite.emptyI finite.insertI singletonI)
  qed
  show "\<And>A C. A \<in> gen_boolean_algebra S B \<Longrightarrow>
           \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs \<Longrightarrow>
           C \<in> gen_boolean_algebra S B \<Longrightarrow>
           \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Bs \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<union> C \<in> gen_boolean_algebra S Bs"
  proof- fix A C
    assume A: "A \<in> gen_boolean_algebra S B"
           "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs"
           "C \<in> gen_boolean_algebra S B"
           "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Bs"
    obtain As where As_def: "finite As \<and> As \<subseteq> B \<and> A \<in> gen_boolean_algebra S As"
      using A by blast
    obtain Cs where Cs_def: "finite Cs \<and> Cs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Cs"
      using A by blast
    obtain Bs where Bs_def: "Bs = As \<union> Cs"
      by blast
    have Bs_sub: "Bs \<subseteq> B"
      unfolding Bs_def using As_def Cs_def by blast
    have 0: " A \<union> C \<in> gen_boolean_algebra S Bs"
      unfolding Bs_def
      apply(rule gen_boolean_algebra_generators_union)
      using As_def apply blast
      using Cs_def by blast
    have 1: "finite Bs"
      unfolding Bs_def using As_def Cs_def by blast
    show " \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<union> C \<in> gen_boolean_algebra S Bs"
      using Bs_sub 0 1 by blast
  qed
  show "\<And>A. A \<in> gen_boolean_algebra S B \<Longrightarrow>
         \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> S - A \<in> gen_boolean_algebra S Bs"
    using gen_boolean_algebra.complement by blast
qed

lemma gen_boolean_algebra_univ_mono:
  assumes "A \<in>  gen_boolean_algebra S B"
  shows "gen_boolean_algebra A B \<subseteq> gen_boolean_algebra S B "
proof(rule subsetI) fix x assume A: "x \<in> gen_boolean_algebra A B"
  obtain a where a_def: "a = A"
    by blast
  have 0: "a \<in> gen_boolean_algebra S B"
    unfolding a_def using assms by blast
  have 1: "a = A \<inter> S"
    using assms gen_boolean_algebra_subset unfolding a_def by blast
  show "x \<in> gen_boolean_algebra S B "
    apply(rule gen_boolean_algebra.induct[of x a B])
    using A a_def apply blast apply(rule 0)
    apply (metis 1 Int_left_commute assms gen_boolean_algebra.intros(2) gen_boolean_algebra_intersect)
     apply(rule gen_boolean_algebra.union, blast, blast)
    apply(rule gen_boolean_algebra_diff)
     apply(rule 0)
    by blast
qed

text\<open>
  The boolean algebra generated by a collection of elements in another algebra is contained
  in the original algebra:
\<close>
lemma gen_boolean_algebra_subalgebra:
  assumes "Xs \<subseteq> gen_boolean_algebra S B"
  shows "gen_boolean_algebra S Xs \<subseteq> gen_boolean_algebra S B"
proof fix x assume A: "x \<in> gen_boolean_algebra S Xs"
  show "x \<in> gen_boolean_algebra S B "
    apply(rule gen_boolean_algebra.induct[of x S Xs])
        apply (simp add: A; fail)
       apply (simp add: gen_boolean_algebra.universe; fail)
    using assms gen_boolean_algebra.universe gen_boolean_algebra_intersect apply blast
  apply (simp add: gen_boolean_algebra.union; fail)
  by (simp add: gen_boolean_algebra.complement)
qed

lemma gen_boolean_algebra_idempotent:
  assumes "S = \<Union> Xs"
  shows "gen_boolean_algebra S (gen_boolean_algebra S Xs) = (gen_boolean_algebra S Xs)"
  apply(rule equalityI)
   apply(rule subsetI)
  apply (meson equalityD2 gen_boolean_algebra_subalgebra in_mono)
   apply(rule subsetI)
  by (metis gen_boolean_algebra.simps gen_boolean_algebra_subset inf.absorb1)

text\<open>We can always replace the set of generators \<open>Xs\<close> with their intersections with the universe
  set \<open>S\<close>, and obtain the same algebra.\<close>

lemma gen_boolean_algebra_restrict_generators:
"gen_boolean_algebra S Xs =gen_boolean_algebra S ((\<inter>) S ` Xs)"
proof(rule equalityI')
  fix x assume A: "x \<in> gen_boolean_algebra S Xs"
  show "x \<in> gen_boolean_algebra S ((\<inter>) S ` Xs)"
    apply(rule gen_boolean_algebra.induct[of x S Xs], rule A, rule gen_boolean_algebra.universe)
    apply (metis gen_boolean_algebra.generator image_eqI inf.right_idem inf_commute)
     apply(rule gen_boolean_algebra.union, blast, blast)
    by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
next
  fix x assume A: "x \<in> gen_boolean_algebra S ((\<inter>) S ` Xs)"
  show "x \<in> gen_boolean_algebra S Xs"
    apply(rule gen_boolean_algebra.induct[of x S "(\<inter>) S ` Xs"], rule A, rule gen_boolean_algebra.universe,
       rule gen_boolean_algebra_intersect )
    using gen_boolean_algebra.generator[of _ Xs S]
       apply (metis (no_types, lifting) Int_commute image_iff)
      apply(rule gen_boolean_algebra.universe)
     apply(rule gen_boolean_algebra.union, blast, blast)
    by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
qed

text\<open>Adding a generator to a generated boolean algebra is redundant if the generator already
      lies in the algebra.\<close>

lemma add_generators:
  assumes "A \<in> gen_boolean_algebra S Xs"
  shows "gen_boolean_algebra S Xs = gen_boolean_algebra S (insert A Xs)"
proof(rule equalityI')
  fix x assume A: "x \<in> gen_boolean_algebra S Xs"
  show "x \<in> gen_boolean_algebra S (insert A Xs)"
    apply(rule gen_boolean_algebra.induct[of x S Xs], rule A, rule gen_boolean_algebra.universe)
      apply(rule gen_boolean_algebra.generator, blast)
     apply(rule gen_boolean_algebra.union, blast,blast)
   by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
next
  fix x assume A: "x \<in> gen_boolean_algebra S (insert A Xs)"
  show "x \<in> gen_boolean_algebra S Xs"
    apply(rule gen_boolean_algebra.induct[of x S "insert A Xs"], rule A, rule gen_boolean_algebra.universe)
    using assms gen_boolean_algebra.generator[of _ Xs S]
    using gen_boolean_algebra.universe gen_boolean_algebra_intersect apply blast
     apply(rule gen_boolean_algebra.union, blast, blast)
       by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
qed
(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>Turning a Family of Sets into a Family of Disjoint Sets\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>
  This section outlines the standard construction where sets $A_0, \dots, A_n$ are replaced by sets
  $A_0, A_1 - A_0, A_2 - (A_0 \cup A_1), ..., A_n - (\bigcup \limits_{i = 0}^{n-1} A_i)$ to obtain
  a disjoint family of the same cardinality.
\<close>
fun rec_disjointify where
"rec_disjointify 0 f = {}"|
"rec_disjointify (Suc m) f = insert (f m - \<Union> (rec_disjointify m f)) (rec_disjointify m f)"

lemma card_of_rec_disjointify:
"card (rec_disjointify m f) \<le> m"
  apply(induction m) unfolding rec_disjointify.simps
   apply simp
  by (metis Suc_le_mono card.infinite card_insert_disjoint finite_insert insert_absorb le_SucI)

lemma rec_disjointify_finite:
"finite (rec_disjointify m f)"
  apply(induction m)
  unfolding rec_disjointify.simps by auto

lemma rec_disjointify_in_gen_boolean_algebra:
  assumes "f ` {..<m} \<subseteq> gen_boolean_algebra S B"
  shows  "rec_disjointify m f \<subseteq> gen_boolean_algebra S B"
proof-
  have "\<And>k. k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
  proof- fix k  show "k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
      apply(induction k) unfolding rec_disjointify.simps(1) using assms apply blast
    proof fix k
      assume IH: " k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
                 "Suc k \<le> m"
      then have 0: "rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
        by (simp add: IH(2))
      have 1: "finite (rec_disjointify k f )"
        using rec_disjointify_finite by blast
      have 2: "f k \<in> gen_boolean_algebra S B"
        using IH(2) assms
        by (simp add: image_subset_iff)
      show "rec_disjointify (Suc k) f \<subseteq> gen_boolean_algebra S B"
        using 0 1 2 unfolding rec_disjointify.simps
        by (simp add: gen_boolean_algebra_diff gen_boolean_algebra_finite_union subset_iff)
    qed
  qed
  thus ?thesis by blast
qed

lemma rec_disjointify_union:
"\<Union> (rec_disjointify m f) = (\<Union> i \<in> {..<m}. f i)"
  apply(induction m)
   apply simp unfolding rec_disjointify.simps insert_def
  apply(rule equalityI, rule subsetI)
  apply (simp add: lessThan_Suc; fail)
  apply(rule subsetI)
  by (simp add: lessThan_Suc)

definition enum_rec_disjointify where
"enum_rec_disjointify f m = f m - \<Union> (rec_disjointify m f)"

lemma rec_disjointify_as_enum_rec_disjointify_image:
"rec_disjointify m f = enum_rec_disjointify f  ` {..<m}"
  apply(induction m)
  unfolding rec_disjointify.simps
   apply (simp; fail)
  unfolding enum_rec_disjointify_def
  using lessThan_Suc by auto

lemma enum_rec_disjointify_subset:
"enum_rec_disjointify f m \<subseteq> f m"
    unfolding enum_rec_disjointify_def
    by auto

lemma enum_rec_disjointify_disjoint:
  assumes "k < m"
  shows "enum_rec_disjointify f m \<inter> enum_rec_disjointify f k = {}"
proof-
  have "enum_rec_disjointify f k \<subseteq> \<Union> (rec_disjointify m f)"
    unfolding rec_disjointify_union
    using assms enum_rec_disjointify_subset by fastforce
  thus ?thesis
     unfolding enum_rec_disjointify_def
     by auto
qed

lemma enum_rec_disjointify_disjoint':
  assumes "k \<noteq> m"
  shows "enum_rec_disjointify f m \<inter> enum_rec_disjointify f k = {}"
  apply(cases  "k < m") using enum_rec_disjointify_disjoint[of k m f]
   apply simp
  using assms enum_rec_disjointify_disjoint[of m k f] by auto

lemma rec_disjointify_is_disjoint:
  assumes "A \<in> rec_disjointify m f"
  assumes "B \<in>  rec_disjointify m f"
  assumes "A \<noteq> B"
  shows "A \<inter> B = {}"
  using  rec_disjointify_as_enum_rec_disjointify_image enum_rec_disjointify_disjoint' assms
  by (smt image_iff)

definition enumerates where
"enumerates A f \<equiv> finite A \<and> A = f ` {..< (card A)} \<and> inj_on f {..< (card A)}"

lemma finite_imp_exists_enumeration:
  assumes "finite A"
  shows "\<exists>f. enumerates A f"
  unfolding enumerates_def
  using assms finite_imp_nat_seg_image_inj_on[of A]
  by (metis card_Collect_less_nat card_image lessThan_def)

lemma enumeratesE:
  assumes "enumerates A f"
  shows "finite A" "A = f ` {..< card A}" "inj_on f {..< card A}"
  using assms unfolding enumerates_def  apply blast
  using assms unfolding enumerates_def  apply blast
  using assms unfolding enumerates_def  by blast

lemma rec_disjointify_finite_set:
  assumes "enumerates A f"
  shows "\<Union> (rec_disjointify (card A) f) = \<Union> A"
  unfolding rec_disjointify_union[of "card A" f]
  using enumeratesE[of A f] assms by auto

definition enumerate where
"enumerate A = (SOME f. enumerates A f)"

lemma enumerate_enumerates:
  assumes "finite A"
  shows "enumerates A (enumerate A)"
  unfolding enumerate_def using finite_imp_exists_enumeration assms
  by (simp add: finite_imp_exists_enumeration some_eq_ex)

lemma enumerateE:
  assumes "finite A"
  assumes "a \<in> A"
  shows "\<exists> i < card A. a = (enumerate A) i"
  using  enumerate_enumerates[of A] enumeratesE[of A] assms by blast

definition disjointify where
"disjointify As = rec_disjointify (card As) (enumerate As)"

lemma disjointify_is_disjoint:
  assumes "finite As"
  assumes "A \<in> disjointify As"
  assumes "B \<in> disjointify As"
  assumes "A \<noteq>  B"
  shows "A \<inter> B = {}"
  using assms rec_disjointify_is_disjoint[of A _ _ B] unfolding disjointify_def
  by simp

lemma disjointify_union:
  assumes "finite As"
  shows "\<Union> (disjointify As)  = \<Union> As"
  using assms
  by (simp add: disjointify_def enumerate_enumerates rec_disjointify_finite_set)

lemma disjointify_gen_boolean_algebra:
  assumes "finite As"
  assumes "As \<subseteq> gen_boolean_algebra S B"
  shows " disjointify As \<subseteq> gen_boolean_algebra S B"
  using assms unfolding disjointify_def
  by (metis enumerate_enumerates enumeratesE(2) rec_disjointify_in_gen_boolean_algebra)

lemma disjointify_finite:
  assumes "finite As"
  shows "finite (disjointify As)"
  using assms unfolding disjointify_def
  by (simp add: rec_disjointify_finite)

lemma disjointify_card:
  assumes "finite As"
  shows"card  (disjointify As) \<le> card As"
  by (simp add: card_of_rec_disjointify disjointify_def)

lemma disjointify_subset:
  assumes "finite As"
  assumes "A \<in> disjointify As"
  shows "\<exists>B \<in> As. A \<subseteq> B"
  using assms enum_rec_disjointify_subset enumerate_enumerates enumeratesE
  unfolding disjointify_def
  by (smt image_iff rec_disjointify_as_enum_rec_disjointify_image)

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>The Atoms Generated by Collections of Sets\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>
  We can also turn a family of sets into a disjoint family by taking the atoms of the boolean
  algebra generated by these sets. This will still yield a finite family if the initial family is
  finite, but in general will be much larger in size.
\<close>

(**********************************************************************)
(**********************************************************************)
subsubsection\<open>Defining the Atoms of a Family of Sets\<close>
(**********************************************************************)
(**********************************************************************)
text\<open>
  Here we intend that \<open>As\<close> is a subset of the collection of sets \<open>Xs\<close>. This function associate to each
  subset \<open>As \<subseteq> Xs\<close> a set which is contained in each element of \<open>As\<close>, and is disjoint from
  each element of \<open>Xs - As\<close>. Note that in general this may yield the empty set, but we will
  ultimately be interested in the cases where the result is nonempty.\<close>

definition subset_to_atom where
"subset_to_atom Xs As = \<Inter> As - \<Union> (Xs - As)"

lemma subset_to_atom_memI:
  assumes "\<And>A. A \<in> As \<Longrightarrow> x \<in> A"
  assumes "\<And>A. A \<in> Xs \<Longrightarrow> A \<notin> As \<Longrightarrow> x \<notin> A"
  shows "x \<in> subset_to_atom Xs As"
  using assms unfolding subset_to_atom_def
  by blast

lemma subset_to_atom_memE:
  assumes "x \<in> subset_to_atom Xs As"
  shows "\<And>A. A \<in> As \<Longrightarrow> x \<in> A"
        "\<And>A. A \<in> Xs \<Longrightarrow> A \<notin> As \<Longrightarrow> x \<notin> A"
  using assms unfolding subset_to_atom_def by auto

lemma subset_to_atom_closed:
  assumes "As \<noteq> {}"
  assumes "As \<subseteq> Xs"
  shows "subset_to_atom Xs As \<subseteq> \<Union> Xs"
proof-
  have 0: "\<Inter> As \<subseteq> \<Union> As "
    apply(rule subsetI)
    using assms(1) by blast
  show ?thesis
  apply(rule subsetI)
  using assms 0 unfolding subset_to_atom_def
  by (meson DiffD1 Union_mono subsetD)
qed

lemma subset_to_atom_as_intersection:
  assumes "As \<noteq> {}"
  assumes "As \<subseteq> Xs"
  assumes "S = \<Union> Xs"
  shows "subset_to_atom Xs As = \<Inter> As \<inter> (\<Inter> X \<in> Xs - As. S - X)"
  unfolding assms subset_to_atom_def
  apply(rule equalityI')
   apply(rule IntI, blast)
  apply(rule InterI)
  using INT_I assms(1) assms(2) apply auto[1]
  apply(rule DiffI, blast)
  by blast

definition atoms_of where
"atoms_of Xs = (subset_to_atom Xs  ` ((Pow Xs) - {{}})) - {{}}"

lemma atoms_nonempty:
  assumes "A \<in> atoms_of Xs"
  shows "A \<noteq> {}"
  using assms unfolding atoms_of_def by blast

lemma atoms_of_disjoint:
  assumes "A \<in> atoms_of Xs"
  assumes "B \<in> atoms_of Xs"
  assumes "A \<noteq> B"
  shows "A \<inter> B = {}"
proof-
  obtain a where a_def: "a \<subseteq> Xs \<and> A = subset_to_atom Xs a"
    using assms  unfolding atoms_of_def by blast
  obtain b where b_def: "b \<subseteq> Xs \<and> B = subset_to_atom Xs b"
    using assms  unfolding atoms_of_def by blast
  have a_neq_b: "a \<noteq> b"
    using assms   a_def b_def by blast
  have  "A \<inter> B \<subseteq> {}"
  proof fix x assume A: "x \<in> A \<inter> B"
    show "x \<in> {}"
    proof(cases "a \<subseteq> b")
      case True
      then obtain c where c_def: "c \<in> b - a"
        using a_neq_b by blast
      have c_in_Xs: "c \<in> Xs"
        using c_def b_def by blast
      have x_in_c: "x \<in> c"
        using A  b_def c_def subset_to_atom_memE[of x Xs b c] by blast
      have x_notin_c: "x \<notin> c"
        using A  a_def c_in_Xs c_def subset_to_atom_memE[of x Xs a c] by blast
      then show ?thesis using x_in_c by blast
    next
      case False
      then obtain c where c_def: "c \<in> a - b"
        using a_neq_b by blast
      have c_in_Xs: "c \<in> Xs"
        using c_def a_def by blast
      have x_in_c: "x \<in> c"
        using A  a_def c_def subset_to_atom_memE[of x Xs a c] by blast
      have x_notin_c: "x \<notin> c"
        using A  b_def c_in_Xs c_def subset_to_atom_memE[of x Xs b c] by blast
      then show ?thesis using x_in_c by blast
    qed
  qed
  thus "A \<inter> B = {}"
    by blast
qed

text \<open>
  The atoms of a family of sets \<open>Xs\<close> are minimal in the sense that they are either contained in or
  disjoint from each element of \<open>Xs\<close>.
\<close>
lemma atoms_are_minimal:
  assumes "A \<in> atoms_of Xs"
  assumes "X \<in> Xs"
  shows "X \<inter> A = {} \<or> A \<subseteq> X"
proof(cases "X \<inter> A = {}")
  case True
  then show ?thesis by blast
next
  case False
  obtain As where As_def: "As \<in> Pow Xs - {{}} \<and> A = subset_to_atom Xs As"
    using assms unfolding atoms_of_def by blast
  have A_simp: "A = subset_to_atom Xs As"
    using As_def by blast
  then show ?thesis using assms  unfolding atoms_of_def subset_to_atom_def A_simp
  using DiffD1 subset_eq by auto
qed

(**********************************************************************)
(**********************************************************************)
subsubsection\<open>Atoms Induced by Types of Points\<close>
(**********************************************************************)
(**********************************************************************)
text\<open>
  The set of sets in \<open>Xs\<close> which contain some point \<open>x\<close>. In the case where \<open>Xs\<close> is some collection of
  first order formulas, this is just the type of \<open>x\<close> over these formulas.\<close>
definition point_to_type where
"point_to_type Xs x = {X \<in> Xs. x \<in> X}"

text \<open>The type of a point \<open>x\<close> induces the unique atom of \<open>Xs\<close> which contains \<open>x\<close>.\<close>
lemma point_in_atom_of_type:
  assumes "x \<in> \<Union> Xs"
  shows "x \<in> subset_to_atom Xs (point_to_type Xs x)"
  using assms unfolding subset_to_atom_def  point_to_type_def
  by blast

lemma point_to_type_nonempty:
  assumes "x \<in> \<Union> Xs"
  shows "point_to_type Xs x \<noteq>{}"
  using assms unfolding point_to_type_def
  by blast

lemma point_to_type_closed:
 "point_to_type Xs x \<subseteq> Pow (\<Union> Xs)"
  unfolding point_to_type_def
  by blast

lemma atoms_of_covers:
  assumes "X = \<Union> Xs"
  shows "\<Union> (atoms_of Xs) = X"
proof
  show " \<Union> (atoms_of Xs) \<subseteq> X"
  proof fix x assume A: "x \<in> \<Union> (atoms_of Xs)"
    then obtain As where As_def: "As \<in> Pow Xs - {{}} \<and> x \<in> subset_to_atom Xs As"
      unfolding atoms_of_def  by blast
    have "subset_to_atom Xs As \<subseteq>  \<Union> Xs"
      using subset_to_atom_closed[of As Xs] As_def by blast
    then show "x \<in> X" unfolding assms
      using As_def by blast
  qed
  show "X \<subseteq> \<Union> (atoms_of Xs)" apply(rule subsetI)
    using point_to_type_nonempty point_in_atom_of_type point_to_type_closed
    unfolding  assms point_to_type_def atoms_of_def
    by fastforce
qed

lemma atoms_of_covers':
  shows "\<Union> (atoms_of Xs) = \<Union> Xs"
  using atoms_of_covers[of "\<Union> Xs"] by blast

text \<open>Every atom of a collection \<open>Xs\<close> of sets is realized as the atom generated by the type of
   an element in that atom.\<close>
lemma nonemtpy_atom_from_point_to_type:
  assumes "A \<in> atoms_of Xs"
  assumes "a \<in> A"
  shows "A = subset_to_atom Xs (point_to_type Xs a)"
proof-
  obtain As where As_def: "As \<in> (Pow Xs) - {} \<and> A = subset_to_atom Xs As"
    using assms unfolding atoms_of_def by blast
  have A_simp: "A = subset_to_atom Xs As"
    using As_def by blast
  have 0: "As = point_to_type Xs a"
    apply(rule  equalityI)
    apply(rule  subsetI)
    apply (smt As_def Diff_empty UnionI Union_Pow_eq assms point_in_atom_of_type subset_to_atom_memE(1) subset_to_atom_memE(2))
    apply(rule subsetI)
    using As_def assms subset_to_atom_memE(2)
    by (metis (no_types, lifting) mem_Collect_eq point_to_type_def)
  show ?thesis
    using point_in_atom_of_type 0
          atoms_of_covers'[of Xs] assms  unfolding A_simp
    by auto
qed

text \<open>
  In light of the previous theorem, a point a and a collection of sets \<open>Xs\<close> is enough to recover
  the the unique atom of \<open>Xs\<close> which contains \<open>a\<close>.
\<close>
definition point_to_atom where
"point_to_atom Xs a = subset_to_atom Xs (point_to_type Xs a)"

lemma point_to_atom_closed:
  assumes "x \<in> \<Union> Xs"
  shows "point_to_atom Xs x \<in> atoms_of Xs"
  using assms unfolding atoms_of_def point_to_atom_def
  by (metis (full_types) Union_iff atoms_of_covers atoms_of_def nonemtpy_atom_from_point_to_type)

text \<open>All atoms of \<open>Xs\<close> are the atom induced by some point in the union of \<open>Xs\<close>.\<close>
lemma atoms_induced_by_points:
"atoms_of Xs = point_to_atom Xs ` (\<Union> Xs)"
  apply(rule equalityI)
   apply(rule subsetI)
  using nonemtpy_atom_from_point_to_type atoms_nonempty atoms_of_covers'
  unfolding point_to_atom_def
  apply (smt DiffE Pow_empty Pow_iff atoms_of_def image_iff subsetD subsetI subset_to_atom_closed)
     apply(rule subsetI)
  by (metis (no_types, lifting) imageE point_to_atom_closed point_to_atom_def)

(**********************************************************************)
(**********************************************************************)
subsubsection\<open>Atoms of Generated Boolean Algebras\<close>
(**********************************************************************)
(**********************************************************************)

lemma atoms_of_gen_boolean_algebra:
  assumes "Xs \<subseteq> gen_boolean_algebra S B"
  assumes "finite Xs"
  shows "atoms_of Xs \<subseteq> gen_boolean_algebra S B"
proof
  fix x assume A: "x \<in> atoms_of Xs"
  then obtain As where As_def: "As \<in> ((Pow Xs) - {{}}) \<and> x = subset_to_atom Xs As"
    unfolding atoms_of_def by blast
  have x_simp: "x = subset_to_atom Xs As"
    using As_def by blast
  have 0: "finite As"
    using As_def assms finite_subset by auto
  have 1: "As \<subseteq> gen_boolean_algebra S B"
    using As_def assms by blast
  have 2: "\<Inter> As \<in> gen_boolean_algebra S B"
    using 0 1 assms
    by (metis As_def DiffE gen_boolean_algebra_finite_intersection singletonI subset_eq)
  show "x \<in> gen_boolean_algebra S B"
    using A 2 unfolding atoms_of_def subset_to_atom_def x_simp
    by (metis (no_types, lifting) As_def DiffD1 Diff_partition Pow_iff Un_subset_iff assms(1) assms(2) finite_subset gen_boolean_algebra_diff gen_boolean_algebra_finite_union order_refl subsetD)
qed

text \<open>If the generators of a boolean algebra are contained in the universe, the atoms induced by
  the generators alone are minimal elements of the entire algebra.\<close>
lemma finite_algebra_atoms_are_minimal:
  assumes "finite Xs"
  assumes "\<Union> Xs \<subseteq> S"
  assumes "A \<in> atoms_of Xs"
  assumes "X \<in> gen_boolean_algebra S Xs"
  shows "X \<inter> A = {} \<or> A \<subseteq> X"
  apply(rule gen_boolean_algebra.induct[of X S Xs])
  apply (simp add: assms(4); fail)
  apply (metis Union_upper assms(2) assms(3) atoms_of_covers dual_order.trans)
  using assms(2) assms(3) atoms_are_minimal apply fastforce
  apply blast
  using assms
  by (metis Diff_Int_distrib2 Diff_empty Diff_eq_empty_iff Sup_upper atoms_of_covers' equalityE inf.absorb_iff2 order_trans)

lemma finite_set_imp_finite_atoms:
  assumes "finite Xs"
  shows "finite (atoms_of Xs)"
  using assms unfolding atoms_of_def
  by blast

text \<open>
  Every element in the boolean algebra generated by \<open>Xs\<close> over \<open>S\<close> is a (disjoint) union
  of atoms of generators:
\<close>

lemma gen_boolean_algebra_elem_uni_of_atoms:
  assumes "finite Xs"
  assumes "S = \<Union> Xs"
  assumes "X \<in> gen_boolean_algebra S Xs"
  shows "X = \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
proof
  show "X \<subseteq> \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
  proof fix x assume A: "x \<in> X"
    then have "point_to_atom Xs x \<in> atoms_of Xs"
      using assms by (meson gen_boolean_algebra_subset point_to_atom_closed subsetD)
    then show "x \<in> \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
      by (smt A IntI Union_iff assms(1) assms(2) assms(3) empty_iff finite_algebra_atoms_are_minimal gen_boolean_algebra.universe gen_boolean_algebra_subset mem_Collect_eq point_in_atom_of_type point_to_atom_def subsetD)
  qed
  show "\<Union> {a \<in> atoms_of Xs. a \<subseteq> X} \<subseteq> X"
    by blast
qed

text\<open>In fact, every generated boolean algebra is the power set of the atoms of its generators:\<close>
lemma gen_boolean_algebra_generated_by_atoms:
  assumes "finite Xs"
  assumes "S = \<Union> Xs"
  shows "gen_boolean_algebra S Xs = \<Union> ` (Pow (atoms_of Xs))"
proof
  show "gen_boolean_algebra S Xs \<subseteq> \<Union> ` Pow (atoms_of Xs)"
    apply(rule subsetI)
    using gen_boolean_algebra_elem_uni_of_atoms[of Xs S] assms
    by fastforce
  show "\<Union> ` Pow (atoms_of Xs) \<subseteq> gen_boolean_algebra S Xs"
    apply(rule subsetI)
    using atoms_of_gen_boolean_algebra[of Xs S Xs]
          finite_subset[of _ "atoms_of Xs"] assms
          finite_set_imp_finite_atoms[of Xs]
          gen_boolean_algebra_finite_union[of _ S Xs]
    by (smt Pow_iff Union_upper gen_boolean_algebra.intros(2) image_iff inf.absorb1 subsetD subsetI)
qed

text\<open>Finitely generated boolean algebras are finite\<close>
lemma fin_gens_imp_fin_algebra:
  assumes "finite Xs"
  assumes "S = \<Union> Xs"
  shows "finite (gen_boolean_algebra S Xs)"
  using finite_set_imp_finite_atoms[of Xs] assms gen_boolean_algebra_generated_by_atoms[of Xs S]
  by simp

lemma point_to_atom_equal:
  assumes "finite Xs"
  assumes "S = \<Union> Xs"
  assumes "x \<in> S"
  shows "point_to_atom Xs x = point_to_atom (gen_boolean_algebra S Xs) x"
proof
  show P0: "point_to_atom Xs x \<subseteq> point_to_atom (gen_boolean_algebra S Xs) x"
  proof-
    have 0: "point_to_atom Xs x \<inter> point_to_atom (gen_boolean_algebra S Xs) x \<noteq> {}"
      using assms
      by (metis IntI UnionI empty_iff gen_boolean_algebra.universe point_in_atom_of_type point_to_atom_def)
    have 1: "point_to_atom (gen_boolean_algebra S Xs) x \<in> gen_boolean_algebra S Xs"
      using assms fin_gens_imp_fin_algebra[of Xs S]
      by (meson UnionI atoms_of_gen_boolean_algebra gen_boolean_algebra.simps point_to_atom_closed subset_eq subset_refl)
    then show ?thesis
      using 0 finite_algebra_atoms_are_minimal[of Xs S "point_to_atom Xs x" "point_to_atom (gen_boolean_algebra S Xs) x"]
            assms(1) assms(2) assms(3) atoms_induced_by_points by auto
  qed
  show "point_to_atom (gen_boolean_algebra S Xs) x \<subseteq> point_to_atom Xs x"
  proof-
    have 0: "point_to_atom (gen_boolean_algebra S Xs) x \<inter> point_to_atom Xs x \<noteq>{}"
      using assms P0 point_in_atom_of_type point_to_atom_def by fastforce
    have 1: "point_to_atom (gen_boolean_algebra S Xs) x \<in> (gen_boolean_algebra S Xs)"
      using assms gen_boolean_algebra_idempotent[of S Xs] atoms_of_gen_boolean_algebra
      by (metis UnionI fin_gens_imp_fin_algebra gen_boolean_algebra.universe point_to_atom_closed subset_eq)
    have 2: "\<Union> (gen_boolean_algebra S Xs) \<subseteq> S"
      using assms
      by (simp add: Sup_le_iff gen_boolean_algebra_subset)
    hence 3: "\<Union> (gen_boolean_algebra S Xs) = S"
      by (simp add: Union_upper gen_boolean_algebra.universe subset_antisym)
    have 4: "gen_boolean_algebra S (gen_boolean_algebra S Xs) = gen_boolean_algebra S Xs"
      using assms gen_boolean_algebra_idempotent[of S Xs] by blast
    have 5: "point_to_atom Xs x \<in> gen_boolean_algebra S (gen_boolean_algebra S Xs)"
      unfolding  4 using assms
      by (metis (no_types, opaque_lifting) Int_absorb1 Int_commute Union_upper atoms_of_gen_boolean_algebra gen_boolean_algebra.generator point_to_atom_closed subsetD subsetI)
    show ?thesis
      using 2 5 finite_algebra_atoms_are_minimal[of "gen_boolean_algebra S Xs" S "point_to_atom (gen_boolean_algebra S Xs) x" "point_to_atom Xs x"] 0 1 2
      unfolding 4
      by (metis "3" Int_commute assms(1) assms(2) assms(3) fin_gens_imp_fin_algebra point_to_atom_closed)
  qed
qed

text \<open>
  When the set \<open>Xs\<close> of generators covers the universe set \<open>S\<close>, the atoms of \<open>Xs\<close> in the above
  sense are the same as the atoms of the boolean algebra they generate over \<open>S\<close>.
\<close>

lemma atoms_of_sets_eq_atoms_of_algebra:
  assumes "finite Xs"
  assumes "S = \<Union> Xs"
  shows "atoms_of Xs = atoms_of (gen_boolean_algebra S Xs)"
proof
  show "atoms_of Xs \<subseteq> atoms_of (gen_boolean_algebra S Xs)"
  proof fix A assume A: "A \<in> atoms_of Xs"
    then obtain x where x_def: "x \<in> S \<and> A = point_to_atom Xs x"
      using assms
      by (metis atoms_induced_by_points image_iff)
    have 0: "A = point_to_atom (gen_boolean_algebra S Xs) x"
      using assms point_to_atom_equal  x_def by fastforce
    show "A \<in> atoms_of (gen_boolean_algebra S Xs)"
      unfolding 0 using assms A
      by (metis (full_types) "0" UnionI gen_boolean_algebra.universe point_to_atom_closed x_def)
  qed
  show "atoms_of (gen_boolean_algebra S Xs) \<subseteq> atoms_of Xs"
  proof fix A  assume A: "A \<in> atoms_of (gen_boolean_algebra S Xs)"
    then obtain x where x_def: "x \<in> S \<and> A  = point_to_atom (gen_boolean_algebra S Xs) x"
      by (metis atoms_induced_by_points cSup_eq_maximum gen_boolean_algebra.universe gen_boolean_algebra_subset image_iff)
    then show "A \<in> atoms_of Xs"
      using assms(1) assms(2) point_to_atom_closed point_to_atom_equal by fastforce
  qed
qed

lemma atoms_closed:
  assumes "finite Xs"
  assumes "A \<in> atoms_of (gen_boolean_algebra S Xs)"
  assumes "S = \<Union> Xs"
  shows "A \<in> (gen_boolean_algebra S Xs)"
proof-
  have 1: "A = \<Union> {A}"
    by blast
  have 2: "A \<in> atoms_of Xs"
    using assms atoms_of_sets_eq_atoms_of_algebra
    by blast
  show ?thesis
  using gen_boolean_algebra_generated_by_atoms[of Xs S]
        assms 1 2 unfolding Pow_def by blast
qed

lemma atoms_finite:
  assumes "finite Xs"
  shows "finite ((atoms_of (gen_boolean_algebra S Xs)))"
proof-
  have 0: "gen_boolean_algebra S Xs =gen_boolean_algebra S ((\<inter>) S ` Xs)"
    using gen_boolean_algebra_restrict_generators by blast
  have 1: "gen_boolean_algebra S Xs = gen_boolean_algebra S (insert S ((\<inter>) S ` Xs))"
    unfolding 0 by(rule add_generators, rule gen_boolean_algebra.universe)
  obtain Ys where Ys_def: "Ys = (insert S ((\<inter>) S ` Xs))"
    by blast
  have Ys_finite: "finite Ys"
    unfolding Ys_def using assms by blast
  have 2: "\<Union> Ys = S"
    unfolding Ys_def
    by blast
  have 3: "atoms_of Ys = atoms_of (gen_boolean_algebra S Xs) "
    unfolding Ys_def 1
    apply(rule atoms_of_sets_eq_atoms_of_algebra)
    using Ys_finite unfolding Ys_def apply blast
    by blast
  have 4: "finite (atoms_of Ys)"
    by(rule finite_set_imp_finite_atoms, rule Ys_finite)
  show ?thesis using 4 unfolding 3 by blast
qed

text \<open>
  We can distinguish atoms of a set of generators \<open>Cs\<close> by finding some element of \<open>Cs\<close> which
  includes one and excludes the other.
\<close>

lemma distinct_atoms:
  assumes "Cs \<noteq> {}"
  assumes "a \<in> atoms_of Cs"
  assumes "b \<in> atoms_of Cs"
  assumes "a \<noteq> b"
  shows "(\<exists>B \<in> Cs. b \<subseteq> B \<and> a \<inter> B = {}) \<or> (\<exists>A \<in> Cs. a \<subseteq> A \<and> b \<inter> A = {})"
proof-
  obtain x where x_def: "x \<in> \<Union> Cs \<and> a = point_to_atom Cs x"
    by (metis assms(2) atoms_induced_by_points imageE)
  obtain y where y_def: "y \<in> \<Union> Cs \<and> b = point_to_atom Cs y"
    by (metis assms(3) atoms_induced_by_points imageE)
  have 0: "point_to_atom Cs x \<noteq> point_to_atom Cs y"
    using x_def y_def assms by simp
  hence 1: "point_to_type Cs x \<noteq> point_to_type Cs y"
    unfolding point_to_atom_def subset_to_atom_def by blast
  then obtain B where B_def: "B \<in> Cs \<and> (B \<in> point_to_type Cs x - point_to_type Cs y \<or> B \<in> point_to_type Cs y - point_to_type Cs x)"
    unfolding point_to_type_def by blast
  have 2: "B \<in> point_to_type Cs x - point_to_type Cs y \<Longrightarrow> a \<subseteq> B"
    using x_def  point_to_atom_def subset_to_atom_memE(1) by fastforce
  have 3: "B \<in> point_to_type Cs y - point_to_type Cs y \<Longrightarrow> b \<subseteq> B"
    using y_def by blast
  show ?thesis using B_def 2 3
    by (smt Diff_iff disjoint_iff_not_equal point_to_atom_def subset_eq subset_to_atom_memE(1) subset_to_atom_memE(2) x_def y_def)
qed

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>Partitions of a Set\<close>
(**************************************************************************************************)
(**************************************************************************************************)

definition disjoint :: "'a set set \<Rightarrow> bool" where
"disjoint Ss = (\<forall> A \<in> Ss. \<forall>B \<in> Ss.  A \<noteq>B \<longrightarrow> A \<inter> B = {})"

lemma disjointE:
  assumes "disjoint Ss"
  assumes "A \<in> Ss"
  assumes "B \<in> Ss"
  assumes "A \<noteq>B"
  shows "A \<inter> B = {}"
  by (meson assms(1) assms(2) assms(3) assms(4) disjoint_def)

lemma disjointI:
  assumes "\<And>A B. A \<in> Ss \<Longrightarrow> B \<in> Ss \<Longrightarrow> A \<noteq> B \<Longrightarrow> A \<inter> B = {}"
  shows "disjoint Ss"
  by (meson assms disjoint_def)

definition is_partition  :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "partitions" 75) where
"S partitions A = (disjoint S \<and> \<Union> S = A)"

lemma is_partitionE:
  assumes "S partitions A"
  shows "disjoint S"
        "\<Union> S = A"
  using assms is_partition_def apply blast
  using assms
  by (simp add: is_partition_def)

lemma is_partitionI:
  assumes "disjoint S"
  assumes "\<Union> S = A"
  shows "S partitions A"
  using assms is_partition_def by blast

text \<open>
  If we start with a finite partition of a set \<open>A\<close>, and each element in that partition has a
  finite partition with some property \<open>P\<close>, then \<open>A\<close> itself has a finite partition where each
  element has property \<open>P\<close>.\<close>

lemma iter_partition:
  assumes "As partitions A"
  assumes "finite As"
  assumes "\<And>a. a \<in> As \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)"
  shows "\<exists>Bs. finite Bs \<and> Bs partitions A \<and> (\<forall>b \<in> Bs. P b)"
proof-
  obtain F where F_def: "F = (\<lambda>a. (SOME Bs.  finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)))"
    by blast
  have FE: "\<And>a. a \<in> As \<Longrightarrow> finite (F a) \<and> (F a) partitions a \<and> (\<forall>b \<in> (F a). P b)"
  proof- fix a assume A: "a \<in> As"
    show "finite (F a) \<and> (F a) partitions a \<and> (\<forall>b \<in> (F a). P b)"
      apply(rule SomeE'[of _ "\<lambda>Bs.  finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)"])
      unfolding F_def apply blast
      using assms by (simp add: A)
  qed
  obtain Bs where Bs_def: "Bs = (\<Union> a \<in> As. F a)"
    by blast
  have 0: "finite Bs"
    unfolding Bs_def using FE assms by blast
  have 1: "disjoint Bs"
  proof(rule disjointI)
    fix a b assume A: "a \<in> Bs" "b \<in> Bs" "a \<noteq> b"
    obtain c where c_def: "c \<in> As \<and> a \<in>  F c"
      using Bs_def A by blast
    obtain d where d_def: "d \<in> As \<and> b \<in>  F d"
      using Bs_def A by blast
    have 0: "a \<subseteq> c"
      using c_def FE[of c] is_partitionE(2)[of "F c" c] by blast
    have 1: "b \<subseteq> d"
      using d_def FE[of d] is_partitionE(2)[of "F d" d] by blast
    show "a \<inter> b = {}"
    proof(cases "c = d")
      case True
      show ?thesis apply(rule disjointE[of "F c"])
        unfolding True using FE is_partitionE d_def apply blast
        using c_def unfolding True apply blast
        using d_def apply blast
        by(rule A)
    next
      case False
      have "c \<inter> d = {}"
        apply(rule disjointE[of As])
        using assms is_partitionE apply blast
        using c_def apply blast
        using d_def apply blast
        using False by blast
      then show ?thesis using 0 1 by blast
    qed
  qed
  have 2: "(\<forall>b \<in> Bs. P b)"
    apply(rule )
    unfolding Bs_def using FE
    by blast
  have FE': "\<And>a. a \<in> As \<Longrightarrow> (\<Union> (F a)) = a "
    apply(rule is_partitionE)
    using FE by blast
  have 3: "Bs partitions A"
    apply(rule is_partitionI, rule 1)
apply(rule equalityI')
    unfolding Bs_def using assms is_partitionE(2)[of As A]
      FE' is_partitionE(2) apply blast
  proof-
    fix x assume A: "x \<in> A"
    then obtain a where a_def: "a \<in> As \<and> x \<in> a"
      using assms is_partitionE by blast
    then have "x \<in> (\<Union> (F a))"
      using a_def FE' by blast
    thus " x \<in> \<Union> (\<Union> (F ` As))"
      using a_def A by blast
  qed
  show "\<exists>Bs. finite Bs \<and> Bs partitions A \<and> (\<forall>b\<in>Bs. P b)"
    using 0 2 3 by blast
qed

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>Intersections of Families of Sets\<close>
(**************************************************************************************************)
(**************************************************************************************************)

definition pairwise_intersect where
"pairwise_intersect As Bs = {c. \<exists>a \<in> As. \<exists>b \<in> Bs. c = a \<inter> b}"

lemma partition_intersection:
  assumes "As partitions A"
  assumes "Bs partitions B"
  shows "(pairwise_intersect As Bs) partitions (A \<inter> B)"
proof(rule is_partitionI, rule disjointI)
  fix a b assume a0: "a \<in> pairwise_intersect As Bs" "b \<in> pairwise_intersect As Bs" "a \<noteq> b"
  obtain a1 b1 where def1: "a1 \<in> As \<and> b1 \<in> Bs \<and> a = a1 \<inter> b1"
    using a0 unfolding pairwise_intersect_def by blast
  obtain a2 b2 where def2: "a2 \<in> As \<and> b2 \<in> Bs \<and> b = a2 \<inter> b2"
    using a0 unfolding pairwise_intersect_def by blast
  have 0: "a \<inter> b = (a1 \<inter> a2) \<inter> (b1 \<inter> b2)"
    using def1 def2 by blast
  show " a \<inter> b= {}"
  proof(cases "a1 \<noteq> a2")
    case True
    have T0: "a1 \<inter> a2 = {}"
      apply(rule disjointE[of As a1 a2] )
      using def1 def2 assms(1) True is_partitionE(1)[of As A] apply blast
      using def1 apply blast using def2 apply blast by(rule True)
    thus ?thesis unfolding 0 by blast
  next
    case False
    then have F0: "b1 \<noteq> b2"
      using a0 def1 def2 by blast
    have F1: "b1 \<inter> b2 = {}"
      apply(rule disjointE[of Bs b1 b2])
      using def1 def2 assms(2) F0  is_partitionE(1)[of Bs B] apply blast
      using def1 apply blast using def2 apply blast by(rule F0)
    thus ?thesis unfolding 0 by blast
  qed
next
  show "\<Union> (pairwise_intersect As Bs) = A \<inter> B"
  proof(rule equalityI')
    fix x assume A: "x \<in> \<Union> (pairwise_intersect As Bs)"
    then obtain a b where def1: "a \<in> As \<and> b \<in> Bs \<and> x \<in> a \<inter> b"
      unfolding pairwise_intersect_def by blast
    have 0: "a \<subseteq> A"
      using def1 assms is_partitionE by blast
    have 1: "b \<subseteq> B"
      using def1 assms is_partitionE by blast
    show " x \<in> A \<inter> B"
      using 0 1 def1 by blast
  next
    fix x assume A: "x \<in> A \<inter> B"
    obtain a where a_def: "a \<in> As \<and> x \<in> a"
      using A assms is_partitionE by blast
    obtain b where b_def: "b \<in> Bs \<and> x \<in> b"
      using A assms is_partitionE by blast
    have 0: "x \<in> a \<inter> b"
      using a_def b_def by blast
    show "x \<in> \<Union> (pairwise_intersect As Bs)"
      using a_def b_def 0 unfolding pairwise_intersect_def
      by blast
  qed
qed

lemma pairwise_intersect_finite:
  assumes "finite As"
  assumes "finite Bs"
  shows "finite (pairwise_intersect As Bs)"
proof-
  have 0: "(pairwise_intersect As Bs) = (\<Union> a \<in> As. (\<inter>) a ` Bs)"
    unfolding pairwise_intersect_def
    apply(rule equalityI')
    unfolding mem_Collect_eq apply blast
    by blast
  have 1: "\<And>a. a \<in> As \<Longrightarrow> finite ((\<inter>) a ` Bs)"
    using assms by blast
  show ?thesis unfolding 0 using assms(1) 1 by blast
qed

definition family_intersect where
"family_intersect parts = atoms_of (\<Union> parts)"

lemma family_intersect_partitions:
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
  assumes "finite parts"
  assumes "parts \<noteq> {}"
  shows "family_intersect parts partitions A"
proof(rule is_partitionI)
  show "disjoint (family_intersect parts)"
    apply(rule disjointI)
    unfolding family_intersect_def apply(rule atoms_of_disjoint)
    apply blast
    apply blast
    by blast
  show " \<Union> (family_intersect parts) = A"
  proof-
    have 0: "\<Union> (family_intersect parts) = \<Union> (\<Union> parts)"
      unfolding family_intersect_def
      apply(rule atoms_of_covers)
      by blast
    have 1: "\<And>Ps. Ps \<in> parts \<Longrightarrow> \<Union>Ps = A"
      by(rule is_partitionE, rule assms, blast)
    show ?thesis unfolding 0
      using 1 assms by blast
  qed
qed

lemma family_intersect_memE:
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
  assumes "finite parts"
  assumes "parts \<noteq> {}"
  shows "\<And>Ps a. a \<in> family_intersect parts \<Longrightarrow> Ps \<in> parts \<Longrightarrow> \<exists>P \<in> Ps. a \<subseteq> P"
proof-
  fix Ps a assume A: "a \<in> family_intersect parts" "Ps \<in> parts"
  have 0: "\<Union> Ps = A"
    apply(rule is_partitionE)
    using A assms by blast
  have 1: "\<Union> (family_intersect parts) = A"
    apply(rule is_partitionE)
    using family_intersect_partitions assms by blast
  have 2: "a \<noteq> {}"
    using A unfolding family_intersect_def  atoms_of_def by blast
  obtain P where P_def: "P \<in> Ps \<and> a \<inter> P \<noteq> {}"
    using 0 1 A 2 by blast
  have P_in: "P \<in> (\<Union> parts)"
    using P_def A by blast
  have a_sub: "a \<subseteq> P"
    using atoms_are_minimal P_def A P_in unfolding family_intersect_def by blast
  show "\<exists>P \<in> Ps. a \<subseteq> P"
    using a_sub P_def by blast
qed

lemma family_intersect_mem_inter:
  assumes "\<And>Ps. Ps \<in> (parts:: 'a set set set) \<Longrightarrow> Ps partitions A"
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
  assumes "finite parts"
  assumes "parts \<noteq> {}"
  assumes "a \<in> family_intersect parts"
  shows "\<exists>f. \<forall> Ps \<in> parts. f Ps \<in> Ps \<and> a = (\<Inter> Ps \<in> parts. f Ps)"
proof-
  obtain f where f_def: "f = (\<lambda>Ps:: 'a set set. (SOME P. P \<in> Ps \<and> a \<subseteq> P))"
    by blast
  have f_eval: "\<And>Ps. Ps \<in> parts \<Longrightarrow> f Ps \<in> Ps \<and> a \<subseteq> (f Ps)"
  proof-
    fix Ps assume A: "Ps \<in> parts"
    obtain P where P_def: "P \<in> Ps \<and> a \<subseteq> P"
      using assms family_intersect_memE A by blast
    show " f Ps \<in> Ps \<and> a \<subseteq> f Ps"
      apply(rule SomeE[of "f Ps" _ P])
      unfolding f_def using A apply simp
      by(rule P_def)
  qed
  have 0: "a \<noteq> {}"
    using assms unfolding family_intersect_def
    using atoms_nonempty by blast
  have 1: "a = (\<Inter> Ps \<in> parts. f Ps)"
  proof(rule equalityI)
    show 10: "a \<subseteq> \<Inter> (f ` parts)"
      using f_eval by blast
    show "\<Inter> (f ` parts) \<subseteq> a"
    proof
      fix x assume A: "x \<in> \<Inter> (f ` parts)"
      obtain b where b_def: "b = point_to_atom (\<Union> parts) x"
        by blast
      have b_atom: "b \<in> atoms_of (\<Union> parts)"
        unfolding b_def apply(rule point_to_atom_closed)
        using A f_eval assms by blast
      show x_in_a: "x \<in> a"
      proof(rule ccontr)
        assume "x \<notin> a"
        then have "\<not> b \<subseteq> a"
          using b_def unfolding point_to_atom_def  point_to_type_def  subset_to_atom_def by blast
        hence p0: "a \<noteq> b"
          by blast
        have p1: "b \<inter> a = {}"
          apply(rule atoms_of_disjoint[of _ "(\<Union> parts)"] )
            apply(rule b_atom)
          using assms unfolding family_intersect_def apply blast
          using p0 by blast
        have p2: " (\<exists>B\<in>\<Union> parts. b \<subseteq> B \<and> a \<inter> B = {}) \<or> (\<exists>A\<in>\<Union> parts. a \<subseteq> A \<and> b \<inter> A = {})"
          using distinct_atoms[of "\<Union> parts" a b] assms
          by (metis Sup_bot_conv(1) b_atom equalityI' f_eval family_intersect_def mem_simps(2) p0)
        show False
        proof(cases "(\<exists>B\<in>\<Union> parts. b \<subseteq> B \<and> a \<inter> B = {})")
          case True
          then obtain B where B_def: "B\<in>\<Union> parts \<and> b \<subseteq> B \<and> a \<inter> B = {}"
            by blast
          obtain Ps where Ps_def: "B \<in> Ps \<and> Ps \<in> parts"
            using B_def by blast
          have B_neq: "B \<noteq> f Ps"
            using Ps_def B_def 10 0 by blast
          have B_cap: "B \<inter> f Ps = {}"
            apply(rule disjointE[of Ps])
               apply(rule is_partitionE[of Ps A])
            using Ps_def assms apply blast
            using Ps_def apply blast
            using f_eval Ps_def apply blast
            by(rule B_neq)
          have b_cap: "b \<inter> f Ps = {}"
            using B_cap B_def by blast
          have x_in_b: "x \<in> b"
            using b_def unfolding point_to_atom_def point_to_type_def subset_to_atom_def
            by blast
          show False using x_in_b b_cap Ps_def A by blast
        next
          case False
          then obtain B where B_def: "B\<in>\<Union> parts \<and> a \<subseteq> B \<and> b \<inter> B = {}"
            using p2 by blast
          obtain Ps where Ps_def: "B \<in> Ps \<and> Ps \<in> parts"
            using B_def by blast
          have F0: "B = f Ps"
          proof(rule ccontr)
            assume not: "B \<noteq> f Ps"
            have F0: "B \<inter> f Ps = {}"
             apply(rule disjointE[of Ps])
               apply(rule is_partitionE[of Ps A])
            using Ps_def assms apply blast
            using Ps_def apply blast
            using f_eval Ps_def apply blast
            by(rule not)
            have a_sub: "a \<subseteq> f Ps"
              using 10 Ps_def by blast
            show False using F0 B_def a_sub 0  by blast
          qed
          have x_in_B: "x \<in> B"
            unfolding F0 using A Ps_def by blast
          have x_in_b: "x \<in> b"
            using b_def unfolding point_to_atom_def point_to_type_def subset_to_atom_def
            by blast
          show False using x_in_b x_in_B B_def by blast
        qed
      qed
    qed
  qed
  show ?thesis using f_eval 1 by blast
qed

text \<open>
  If we take a finite family of partitions in a particular generated boolean algebra, where each
  partition itself is finite, then their induced partition is also in the algebra.\<close>
lemma family_intersect_in_gen_boolean_algebra:
  assumes "A \<in> gen_boolean_algebra S B"
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
  assumes "\<And>Ps P. Ps \<in> parts \<Longrightarrow> P \<in> Ps \<Longrightarrow>  P \<in> gen_boolean_algebra S B"
  assumes "finite parts"
  assumes "parts \<noteq> {}"
  shows "\<And>P. P \<in> family_intersect parts \<Longrightarrow> P \<in> gen_boolean_algebra S B"
proof-
  fix P assume A: "P \<in> family_intersect parts"
  have 0: "P \<in> atoms_of (\<Union> parts)"
    using A unfolding family_intersect_def by blast
  have 1: "finite (\<Union> parts)"
    using assms by blast
  have 2: "\<Union> parts \<subseteq> gen_boolean_algebra S B"
    using assms  by blast
  obtain Ps where Ps_def: "Ps \<in> parts"
    using assms by blast
  have 3: "\<Union> (\<Union> parts) = A"
    apply(rule equalityI')
    using assms is_partitionE(2)[of _ A] apply blast
    using assms is_partitionE(2)[of Ps A] Ps_def by blast
  have 4: "atoms_of (\<Union> parts) = atoms_of (gen_boolean_algebra A (\<Union> parts))"
    apply(rule atoms_of_sets_eq_atoms_of_algebra[of "\<Union> parts" A])
     apply(rule 1)
    unfolding 3 by blast
  have 5: "atoms_of (\<Union> parts) \<subseteq>  (gen_boolean_algebra A (\<Union> parts))"
    apply(rule atoms_of_gen_boolean_algebra)
    using 3 gen_boolean_algebra.generator[of _ "\<Union> parts" A]
     apply (meson Sup_upper gen_boolean_algebra_generators subsetI)
    by(rule 1)
  have 6: "A \<subseteq> S"
    using assms gen_boolean_algebra_subset by blast
  have 7: "(gen_boolean_algebra A (\<Union> parts)) \<subseteq> gen_boolean_algebra (S) (\<Union> parts)"
    apply(rule gen_boolean_algebra_univ_mono)
    using 3 gen_boolean_algebra_finite_union[of "\<Union> parts" "S" "\<Union> parts"]
          gen_boolean_algebra.generator[of _ "\<Union> parts" "S" ] 6 1
    by (meson Sup_le_iff gen_boolean_algebra_generators)
  have 8: "gen_boolean_algebra (S) (\<Union> parts) \<subseteq> gen_boolean_algebra S B"
    apply(rule gen_boolean_algebra_subalgebra)
    using 2  by blast
  show "P \<in> gen_boolean_algebra S B"
    using 0 5 6 7 8 by blast
qed

end


theory SortM
imports Main
        Naturals
        Listing
begin

fun sorted :: "nat List \<Rightarrow> bool" where
  "sorted Nil                   = True"
| "sorted (Cons _ Nil)          = True"
| "sorted (Cons r (Cons t ts))  = ( r \<le> t \<and> sorted (Cons t ts))"

fun insert :: "Nat \<Rightarrow> Nat List \<Rightarrow> Nat List" where
  "insert r Nil         = Cons r Nil"
| "insert r (Cons t ts) = (if leq r t then Cons r (Cons t ts) else (Cons t (insert r ts)))"

fun isort :: "Nat List \<Rightarrow> Nat List" where
  "isort Nil = Nil"
| "isort (Cons t ts) = insert t (isort ts)"

fun qsort :: "Nat list \<Rightarrow> Nat list" where
  "qsort [] = []"
| "qsort (t # ts) = (qsort [r <- ts. leq r t]) @ [t] @ (qsort [r <- ts. \<not> (leq r t)])"

thm qsort.induct

fun sorted2 :: "Nat list \<Rightarrow> bool" where
  "sorted2 []                   = True"
| "sorted2 [x]         = True"
| "sorted2 (r # (t # ts))  = (leq r t \<and> sorted2 (t # ts))"

fun merge :: "Nat list \<Rightarrow> Nat list \<Rightarrow> Nat list" where
  "merge rs [] = rs"
| "merge [] ts = ts"
| "merge (r#rs) (t#ts) = (if leq r t then r # merge rs (t#ts)
                                     else t # merge (r#rs) ts)"

fun msort :: "Nat list => Nat list" where
  "msort [] = []"
| "msort [t] = [t]"
| "msort ts = merge (msort (List.take (length ts div 2) ts)) (* size instead? *)
                    (msort (List.drop (length ts div 2) ts))"

lemma lemma_a [thy_expl]: "leq x2 x2 = True"
by (hipster_induct_schemes leq.simps)

lemma lemma_aa [thy_expl]: "leq x2 (S x2) = True"
by (hipster_induct_schemes leq.simps)

lemma lemma_ab [thy_expl]: "leq (S x2) x2 = False"
by (hipster_induct_schemes leq.simps)

(*hipster_cond le*)
lemma lemma_ac [thy_expl]: "leq x2 y2 \<Longrightarrow> leq x2 (S y2) = True"
by (hipster_induct_schemes leq.simps)

lemma lemma_ad [thy_expl]: "leq y2 x2 \<Longrightarrow> leq (S x2) y2 = False"
by (hipster_induct_schemes leq.simps)

lemma lemma_ae [thy_expl]: "leq y x \<and> leq x y \<Longrightarrow> x = y"
by (hipster_induct_schemes leq.simps Nat.exhaust)

lemma le_trans [thy_expl]: "leq z y \<and> leq x z \<Longrightarrow> leq x y = True"
by (hipster_induct_schemes leq.simps Nat.exhaust)

(*hipster_cond leq sorted2 merge leq

hipster_cond sorted2 leq merge sorted2

hipster merge sorted2
*)

(* lemma sortCons: "r \<le> t \<and> sorted2 (t # ts) \<Longrightarrow> sorted2 (r # (t # ts))" by simp *)
lemma insSortInvar : "sorted ts \<Longrightarrow> sorted (insert t ts)"
by hipster_induct_schemes

lemma mer1[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge [] ts)"
(*by(metis sorted2.cases merge.simps)*) (* replace of cases by inductions *)
by hipster_induct_simp_metis

lemma mer2[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge [t] ts)" (* sorted2.induct! *)
by hipster_induct_schemes

lemma mer3[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge ts [t])" (* sorted2.induct! *)
by hipster_induct_schemes

lemma mer4[thy_expl]: "sorted2 (t # ts) \<and> \<not> (leq t r) \<Longrightarrow> sorted2 (r # (merge (t#ts) []))" by simp

lemma mer4'[thy_expl]: "sorted2 (t # ts) \<and> leq t r \<Longrightarrow> sorted2 (t # merge ts [r])"
by (hipster_induct_schemes merge.simps mer3)

lemma mer5'[thy_expl]: "sorted2 (t # ts) \<and> leq r v \<and> \<not> (leq t r) \<Longrightarrow> sorted2 (r # (merge (t#ts) [v]))"
(*apply(induction ts rule: sorted2.induct)
apply(simp_all add: mer4 mer3 mer2 mer1)
apply(metis sorted2.simps merge.simps)*)
by (hipster_induct_schemes merge.simps mer3)

lemma mer5''[thy_expl]: "sorted2 (r # rs) \<and> \<not> (leq t r) \<Longrightarrow> sorted2 (r # (merge [t] rs))"
by (hipster_induct_schemes sorted2.simps)

lemma ssu[thy_expl]: "sorted2 (r # rs) \<and> (leq t r) \<Longrightarrow> sorted2 (t # (merge [] (r#rs)))" by (metis merge.simps sorted2.simps)
(*by (hipster_induct_simp_metis)*)

lemma ssu'[thy_expl]: "sorted2 (r # rs) \<and> (leq t v) \<and> (leq t r) \<Longrightarrow> sorted2 (t # (merge [v] (r#rs)))"
by (metis mer5'' merge.simps sorted2.simps)
lemma ssu''[thy_expl]: " sorted2 [t, v] \<and> sorted2 (r # rs) \<and> leq t r \<Longrightarrow> sorted2 (t # (merge [v] (r#rs)))"
(*by (metis sorted2.simps(3) ssu')*)
by (hipster_induct_schemes sorted2.simps mer5'')

lemma cons1[thy_expl]: "sorted2 (t # ts) \<Longrightarrow> sorted2 ts"
by hipster_induct_simp_metis
(*by (metis sorted2.elims(3) sorted2.simps(3))*)

lemma t1 : "sorted2 ts \<and> ts \<noteq> [] \<and> leq t (hd ts) \<Longrightarrow> sorted2 (t # ts)"
by hipster_induct_simp_metis
(*by (metis list.sel sorted2.elims(3))*)

lemma mer6[thy_expl]: "(sorted2 ts \<and> ts \<noteq> [] \<and> sorted2 (r # rs)) \<Longrightarrow> (sorted2 ((merge ts (r#rs))))"
apply(induction ts rule: sorted2.induct)
apply(induction rs rule: sorted2.induct)
apply(simp_all only: thy_expl)
apply(simp add: ssu'')
apply(rule conjI)
apply(rule impI)
apply(simp add: thy_expl)
apply(rule impI)
apply(rule conjI)
apply(simp add: thy_expl)
apply(simp add: thy_expl)
oops
(*by (hipster_induct_schemes ssu' ssu'' mer5' mer5'' mer3)
sledgehammer
apply(metis sorted2.simps ssu'' mer3 ssu ssu' mer4 mer2 mer1 t1 mer5' mer5'' mer4')*)

(* simplification can very much screw up the goal state! *)
lemma mer5[thy_expl]: "(sorted2 (t # ts) \<and> sorted2 (r # rs) \<and> leq t r) \<Longrightarrow> (sorted2 (t # (merge ts (r#rs))))"
apply(induction ts rule: sorted2.induct)
apply(simp)
apply(simp add: mer5'')
apply(simp add: mer4' mer5'' mer3 ssu' ssu'' ssu)
apply(rule conjI)
apply(rule impI)
apply simp
apply(rule impI, rule conjI)
apply(simp_all)
apply(drule conjE)
apply(simp_all add: ssu' mer5'' mer4 mer4' mer3 mer2 mer1 ssu'' mer5')
(*apply (metis (full_types) sorted2.simps merge.simps if_splits list.exhaust list.distinct)*)
(*apply(simp add: ssu ssu' mer3 mer2 mer1 ssu'' mer5' mer4')*)
(*apply(metis merge.simps(3) mer5' mer4' mer3 mer4)*)
sorry

lemma mergeS: "sorted2 ts \<and> sorted2 rs \<Longrightarrow> sorted2 (merge ts rs)"
apply(induction ts rs rule: merge.induct)
sledgehammer
apply (metis merge.simps(1))
sledgehammer
apply (metis merge.simps(2))
sledgehammer
sledgehammer min [e] (cons1 mer4 mer5 merge.elims merge.simps(1) merge.simps(3) Nat_induct ord.lexordp_eq.simps ord.lexordp_eq_simps(3) qsort.cases sorted2.simps(3))
apply(simp_all add: mer1 mer2)
(*sledgehammer*)
by (metis mer4 mer5 merge.simps sorted2.simps)
(*
apply(cases rs)
apply(simp_all)
by (hipster_induct_schemes mer1 mer5'' mer5 merge.simps sorted2.simps)*)
(*apply(induction ts rule: sorted2.induct)
apply(simp add: mer1)
apply(simp add: mer5'')
by (metis mer4 mer5 merge.simps sorted2.simps)*)
(* apply(induction ts rule: sorted2.induct)
apply(simp add: mer1)
apply(simp add: mer2)
apply(cases rs)
apply(simp_all)
by (metis mer4 mer5 merge.simps sorted2.simps)*)
(*   by (induct xs ys rule: merge.induct) (auto simp add: ball_Un not_le less_le sorted_Cons) *)

lemma smsort: "sorted2 (msort xs)"
by (hipster_induct_schemes mergeS)

(*lemma merComm: "sorted2 ts \<and> sorted2 rs \<Longrightarrow> merge rs ts = merge ts rs"
apply(induction rs ts rule: merge.induct)
apply(simp_all)
apply(metis sorted2.cases merge.simps(1) merge.simps(2))*)

(*
fun merge :: "Nat list \<Rightarrow> Nat list \<Rightarrow> Nat list" where
  "merge [] ts = ts"
| "merge rs [] = rs"
| "merge (r#rs) (t#ts) = (if leq r t then (r # (merge rs (t # ts)) )
                                     else (t # (merge (r # rs) ts) ) )"

fun msort :: "Nat list \<Rightarrow> Nat list" where
  "msort [] = []"
| "msort [t] = [t]"
| "msort ts = merge (msort (take ((length ts) div 2) ts))
                    (msort (drop ((length ts) div 2) ts))*)
(* in a let ... *)

(* qsort *)

end


theory a3
  imports "autocorres-1.4/autocorres/AutoCorres"
begin

(* To run this file you need the AutoCorres tool used
   in the lecture.

  1. Download AutoCorres from
       \url{http://www.cse.unsw.edu.au/~cs4161/autocorres-1.4.tar.gz}

  2. Unpack the .tar.gz file, which will create the directory autocorres-1.4
       tar -xzf autocorres-1.4.tar.gz

  3. Build the AutoCorres heap
     L4V_ARCH=X64 isabelle build -v -b -d autocorres-1.4 AutoCorres

  4. Load this file using the AutoCorres heap
     L4V_ARCH=X64 isabelle jedit -d autocorres-1.4 -l AutoCorres a3.thy

*)

section "Question 1: Regular Expression Matching"

(* Negation is too hard with this one, so we add Null and One instead *)
datatype regexp =
   Null
 | One
 | Atom char
 | Alt regexp regexp
 | Conc regexp regexp (infixl "\<cdot>"  60)
 | Star regexp

(* Same definitions for regular languages as in the lecture, but with Null and One *)
inductive_set star :: "string set \<Rightarrow> string set" for L
  where
  star_empty[simp,intro!]: "[] \<in> star L"
| star_app[elim]: "\<lbrakk> u \<in> L; v \<in> star L \<rbrakk> \<Longrightarrow> u@v \<in> star L"

definition conc :: "string set \<Rightarrow> string set \<Rightarrow> string set"
  where
  "conc A B \<equiv> {xs@ys |xs ys. xs \<in> A \<and> ys \<in> B}"

primrec lang :: "regexp \<Rightarrow> string set"
  where
  "lang Null = {}"
| "lang One = {[]}"
| "lang (Atom c) = {[c]}"
| "lang (Alt e1 e2) = lang e1 \<union> lang e2"
| "lang (Conc e1 e2) = conc (lang e1) (lang e2)"
| "lang (Star e) = star (lang e)"

(* For examples/testing. *)
primrec string :: "char list \<Rightarrow> regexp"
  where
  "string []     = One"
| "string (x#xs) = Atom x \<cdot> string xs"

(* Automatically coerce type "char list" into "regexp" using the function "string" *)
declare [[coercion string]]
(* Enable automatic type coercion *)
declare [[coercion_enabled]]
(* Can now write: *)
term "Star ''abc''"

(* This definition is taken from
   https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/a-regular-expression-matcher
*)
function matches :: "regexp \<Rightarrow> string \<Rightarrow> (string \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "matches Null         cs k = False"
| "matches One          cs k = k cs"
| "matches (Atom c)     cs k = (cs \<noteq> [] \<and> c = hd cs \<and> k (tl cs))"
| "matches (Alt r1 r2)  cs k = (matches r1 cs k \<or> matches r2 cs k)"
| "matches (Conc r1 r2) cs k =  matches r1 cs (\<lambda>cs'. matches r2 cs' k)"
| "matches (Star r)     cs k = (k cs \<or> matches r cs (\<lambda>cs'. if cs' \<noteq> cs
                                                           then matches (Star r) cs' k
                                                           else False))"
  by pat_completeness auto

(* Either change the cs' = cs condition to something more obviously terminating so that
   property "matches_correct" below still holds (easier) or prove termination of the
   version above directly (harder). *)
termination matches
  sorry (* TODO *)

value "matches ''xy'' ''xy'' (op = [])"
value "matches ''xyz'' ''xy'' (op = [])"
value "matches (Star ''xy'') ''xyxy'' (op = [])"

lemma concD[dest!]:
  "xs \<in> conc A B \<Longrightarrow> \<exists>as bs. as \<in> A \<and> bs \<in> B \<and> xs = as@bs"
  by (auto simp: conc_def)

lemma star_cases:
  "xs \<in> star A \<Longrightarrow> xs = [] \<or> (\<exists>u v. xs = u@v \<and> u \<in> A \<and> v \<in> star A \<and> u \<noteq> [])"
  oops (* TODO *)

lemma matches_correct:
  "matches r cs (op = []) = (cs \<in> lang r)"
  oops (* TODO *)

(*-------------------------------------------------*)
section "Question 2: Binary Search"

(* Hints:
    - remember to try the @{text arith} proof method for arithmetic goals on
      integers or natural numbers.
    - use find_theorems to find Isabelle library theorems about existing concepts.
    - the lemma @{thm sorted_equals_nth_mono} might be useful
    - you are allowed to use sledgehammer and other automation
    - if you can't prove one of the lemmas below, you can still assume it in the rest of the proof
    - the function @{const int} converts an Isabelle nat to an int
    - the function @{const nat} converts an Isabelle int to a nat
*)

thm sorted_equals_nth_mono
term int
term nat

install_C_file "binsearch.c"

autocorres [unsigned_word_abs=binary_search] "binsearch.c"

(*******************************************************************************)

context binsearch
begin

(* The monadic definition that autocorres produces for the C code: *)
thm binary_search'_def

(* Abbreviation for signed machine integers *)
type_synonym s_int = "32 signed word"

(* The heap only stores unsigned machine integers;
   they have the same representation as signed ones and can be converted to each other *)
type_synonym u_int = "32 word"

(*******************************************************************************)

(* A few lemmas to help improve automation: *)

(* Pointer arithmetic on pointers to signed and unsigned words is the same *)
lemma ptr_coerce_add_signed_unsigned [simp]:
  "(ptr_coerce ((a :: s_int ptr) +\<^sub>p x) :: u_int ptr) = ptr_coerce a +\<^sub>p x"
  by (cases a) (simp add: ptr_add_def)

(* Pointer arithmetic distributivity law *)
lemma ptr_add_add [simp]:
  "p +\<^sub>p (x + y) = p +\<^sub>p x +\<^sub>p y"
  by (simp add: ptr_add_def distrib_left mult.commute)

(* C division is the same as Isabelle division for non-negative numbers: *)
lemma sdiv [simp]:
  "0 \<le> a \<Longrightarrow> a sdiv 2 = a div (2::int)"
  by (auto simp: sdiv_int_def sgn_if)

(* Some useful facts about INT_MIN and INT_MAX to improve automation: *)
lemma INT_MIN_neg [simp]:
  "INT_MIN < 0"
  by (simp add: INT_MIN_def)
lemma INT_MAX_gr [simp]:
  "- 1 < INT_MAX" "-1 \<le> INT_MAX" "1 \<le> INT_MAX"
  by (auto simp add: INT_MAX_def)

(*******************************************************************************)

(* This function enumerates the addresses of the entries of an signed int array: *)
fun array_addrs :: "s_int ptr \<Rightarrow> nat \<Rightarrow> s_int ptr list" where
  "array_addrs p 0 = []" |
  "array_addrs p (Suc len) = p # array_addrs (p +\<^sub>p 1) len"

text \<open> Prove the following lemma: \<close>
lemma length_array_addrs [simp]:
  "length (array_addrs a len) = len"
  (* TODO *)
  apply (induct len arbitrary: a)
  apply auto
  done

text \<open> Prove the following lemma: \<close>
lemma array_addrs_nth [simp]:
  "\<lbrakk> 0 \<le> x; nat x < len \<rbrakk> \<Longrightarrow> array_addrs a len ! nat x = a +\<^sub>p x"
  (* TODO *)
  apply (induct len arbitrary: a x)
   apply simp+
  apply (case_tac "x = 0")
   apply simp+
  apply (subgoal_tac "\<exists>y. x = 1 + y \<and> 0 \<le> y")
   (* sledgehammer *)
   apply (metis (mono_tags, hide_lams) Suc_less_eq Suc_nat_eq_nat_zadd1 binsearch.ptr_add_add diff_Suc_Suc diff_zero)
  apply (metis le0 less_handy_casesE nat_0_iff nat_code(2) nat_int nat_le_iff nonneg_int_cases of_nat_Suc)
  done

(*******************************************************************************)
text \<open> fill in the array_list definition \<close>
definition array_list :: "(u_int ptr \<Rightarrow> u_int) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> int list" where
  "array_list h p len = map (uint o h o ptr_coerce) (array_addrs p (nat len))"

(* Convert len to nat first
   Then obtain the array address list using array_addrs
   Upon completion of (array_addrs p (nat len)) we will have a list of signed pointers
   ptr_coerce will convert the list of signed pointers to unsigned pointers
   Then the heap function will dereference the value
   Finally, uint will convert the type from signed int to isabelle int
   the map function will apply the above to all elements in the list and will return a list*)

thm uint
thm array_list_def
find_theorems "map (_ o _) _"

(*******************************************************************************)
text \<open> Prove the following lemma: \<close>

lemma ptr_array:
  "\<lbrakk> 0 \<le> x; x < len \<rbrakk> \<Longrightarrow>
   uint (heap_w32 s (ptr_coerce (a :: s_int ptr) +\<^sub>p x)) = array_list (heap_w32 s) a len ! nat x"
  apply (simp add: array_list_def)
  done

(*******************************************************************************)
text \<open> fill in the valid_array definition. It might make sense to do this in two parts and look
   at the invariant and proof obligations first. \<close>

definition valid_array1 :: "(u_int ptr \<Rightarrow> bool) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> bool" where
  "valid_array1 vld p len =
  (\<forall>p' \<in> ptr_coerce ` set (array_addrs p (nat len)). vld p')"

(* set (array_addrs p (nat len)) will return a set of signed integer pointers given p
   p' is the set of unsigned integer pointers given p, applied via ptr_coerce '
   vld p' checks for each element in the modified set whether the pointer value is valid*)

definition valid_array2 :: "(u_int ptr \<Rightarrow> bool) \<Rightarrow> (u_int ptr \<Rightarrow> u_int) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> bool" where
  "valid_array2 vld h p len =
  (\<forall>p' \<in> ptr_coerce ` set (array_addrs p (nat len)). unat (h p') \<le> nat INT_MAX)"

(* same procedure as before; this time the validity of the actual elements are being checked
   this time, we check if each element does not exceed the upper bound of INT_MAX, which
   for 32-bit systems would be estimated to 2^31 - 1 *)

definition valid_array :: "(u_int ptr \<Rightarrow> bool) \<Rightarrow> (u_int ptr \<Rightarrow> u_int) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> bool" where
  "valid_array vld h p len = (valid_array1 vld p len \<and> valid_array2 vld h p len)"

(* valid_array checks two things:
    1. if the pointer value is valid
    2. assuming 1 holds, if the actual value pointed by the pointer is valid
   if both conditions are met, the the array is valid. *)

(*******************************************************************************)

text \<open> Prove the following lemma: \<close>

thm sorted_equals_nth_mono

lemma key_lt:
  "\<lbrakk> key < xs ! nat mid;  mid - 1 < x; sorted xs; 0 \<le> mid; x < int (length xs) \<rbrakk>
  \<Longrightarrow> key < xs ! nat x"
  apply (simp add: sorted_equals_nth_mono)
  apply (case_tac "mid = x")
   apply simp+
  apply (erule_tac x = "nat x" in allE)
  apply (erule impE)
   apply simp+
  apply (erule_tac x = "nat mid" in allE)
  apply (erule impE)
   apply arith+
  apply (simp add: less_le_trans)
  done

text \<open> Prove the following lemma: \<close>
lemma key_gt:
  "\<lbrakk> xs ! nat mid < key; 0 \<le> x; x \<le> mid; sorted xs; mid < int (length xs) \<rbrakk>
  \<Longrightarrow> xs ! nat x < key"
  apply (simp add: sorted_equals_nth_mono)
  apply (case_tac "mid = x")
   apply simp+
  apply (erule_tac x = "nat mid" in allE)
  apply (erule impE)
   apply simp+
  apply (erule_tac x = "nat x" in allE)
  apply (erule impE)
  apply arith+
  apply simp
  done

(*******************************************************************************)

text \<open> extra lemmas needed \<close>

lemma length_array_list [simp]:
  "length (array_list h a len) = nat len"
  unfolding array_list_def by simp

lemma array_addrs:
  "\<lbrakk> 0 \<le> x; nat x < len \<rbrakk> \<Longrightarrow> p +\<^sub>p x \<in> set (array_addrs p len)"
  by (force simp add: set_conv_nth)

lemma valid_arrayD:
  "\<lbrakk> valid_array vld h p len; 0 \<le> x; x < len \<rbrakk>
  \<Longrightarrow> vld (ptr_coerce p +\<^sub>p x) \<and> unat (h (ptr_coerce p +\<^sub>p x)) \<le> nat INT_MAX"
  unfolding valid_array_def valid_array1_def valid_array2_def
  apply clarsimp
  apply (drule bspec)
   apply (fastforce intro: array_addrs)
  apply (drule bspec)
   apply (fastforce intro: array_addrs)
  apply simp
  done

(*******************************************************************************)

lemma binary_search_correct:
  notes ptr_array [where len=len, simp]
  shows
   (* precondition *)
  "\<lbrace>\<lambda>s. sorted (array_list (heap_w32 s) a len) \<and> (* array is sorted *)
        valid_array (is_valid_w32 s) (heap_w32 s) a len \<and> (* all elements and pointers in array is valid *)
        (*TODO*) 0 \<le> len \<and> len + len -2 \<le> INT_MAX \<rbrace> (* range/size of length is valid *)
   (* program *)
   binary_search' a len key
   (* postcondition *)
   \<lbrace> \<lambda>r s. (r < 0 \<longrightarrow> key \<notin> set (array_list (heap_w32 s) a len)) \<and> (* key is not in the array *)
           (0 \<le> r \<longrightarrow> r < len \<and> (array_list (heap_w32 s) a len ! nat r) = key)\<rbrace>! (* if r is a valid nonnegative value, then the rth element is the key *)"
  unfolding binary_search'_def
  apply(subst whileLoopE_add_inv[where
               I="\<lambda>(high,low) s. valid_array (is_valid_w32 s) (heap_w32 s) a len \<and> (* check the validity of the array *)
                                 sorted (array_list (heap_w32 s) a len) \<and> (* check if the elements in the array are sorted *)
                                 (*TODO*) 0 \<le> low \<and> low \<le> len \<and> high < len \<and> len + len -2 \<le> INT_MAX \<and> (* check low and high are within a valid range *)
                                 (\<forall>x. 0 \<le> x \<longrightarrow> x < low \<longrightarrow> array_list (heap_w32 s) a len ! nat x < key) \<and> (* all x less than low are positioned before the key *)
                                 (\<forall>x. high < x \<longrightarrow> x < len \<longrightarrow> array_list (heap_w32 s) a len ! nat x > key) (*  all x greater than high are positioned after the key*)" and
               M="\<lambda>((high,low),_).(*TODO*) nat (high + 1 - low)"]) (* idk *)
  apply (simp add:INT_MAX_def INT_MIN_def)
  apply wp
      prefer 3
      apply wp
     prefer 3
     apply wp
    prefer 3
    apply wp
    apply clarsimp
   apply clarsimp
   apply (rename_tac high low s)
   apply (drule_tac x="(low + high) div 2"
          in valid_arrayD [unfolded INT_MAX_def], simp+)
   apply (intro conjI impI; clarsimp?; arith?)
    apply (erule (2) key_lt, simp+)
   apply (erule (3) key_gt, simp)
  apply clarsimp
  apply (rename_tac high low s)
  apply (clarsimp simp: not_le set_conv_nth)
  apply (drule_tac x="int i" in spec)
  apply (drule_tac x="int i" in spec)
  apply clarsimp
  apply arith

end

end