(*  Title:       HOL/Zorn.thy
    Author:      Jacques D. Fleuriot
    Author:      Tobias Nipkow, TUM
    Author:      Christian Sternagel, JAIST

Zorn's Lemma (ported from Larry Paulson's Zorn.thy in ZF).
*)

section \<open>Zorn's Lemma and the Well-ordering Theorem\<close>

theory Zorn
  imports Order_Relation Hilbert_Choice
begin

subsection \<open>Zorn's Lemma for the Subset Relation\<close>

subsubsection \<open>Results that do not require an order\<close>

text \<open>Let \<open>P\<close> be a binary predicate on the set \<open>A\<close>.\<close>
locale pred_on =
  fixes A :: "'a set"
    and P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubset>" 50)
begin

abbreviation Peq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubseteq>" 50)
  where "x \<sqsubseteq> y \<equiv> P\<^sup>=\<^sup>= x y"

text \<open>A chain is a totally ordered subset of \<open>A\<close>.\<close>
definition chain :: "'a set \<Rightarrow> bool"
  where "chain C \<longleftrightarrow> C \<subseteq> A \<and> (\<forall>x\<in>C. \<forall>y\<in>C. x \<sqsubseteq> y \<or> y \<sqsubseteq> x)"

text \<open>
  We call a chain that is a proper superset of some set \<open>X\<close>,
  but not necessarily a chain itself, a superchain of \<open>X\<close>.
\<close>
abbreviation superchain :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "<c" 50)
  where "X <c C \<equiv> chain C \<and> X \<subset> C"

text \<open>A maximal chain is a chain that does not have a superchain.\<close>
definition maxchain :: "'a set \<Rightarrow> bool"
  where "maxchain C \<longleftrightarrow> chain C \<and> (\<nexists>S. C <c S)"

text \<open>
  We define the successor of a set to be an arbitrary
  superchain, if such exists, or the set itself, otherwise.
\<close>
definition suc :: "'a set \<Rightarrow> 'a set"
  where "suc C = (if \<not> chain C \<or> maxchain C then C else (SOME D. C <c D))"

lemma chainI [Pure.intro?]: "C \<subseteq> A \<Longrightarrow> (\<And>x y. x \<in> C \<Longrightarrow> y \<in> C \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x) \<Longrightarrow> chain C"
  unfolding chain_def by blast

lemma chain_total: "chain C \<Longrightarrow> x \<in> C \<Longrightarrow> y \<in> C \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  by (simp add: chain_def)

lemma not_chain_suc [simp]: "\<not> chain X \<Longrightarrow> suc X = X"
  by (simp add: suc_def)

lemma maxchain_suc [simp]: "maxchain X \<Longrightarrow> suc X = X"
  by (simp add: suc_def)

lemma suc_subset: "X \<subseteq> suc X"
  by (auto simp: suc_def maxchain_def intro: someI2)

lemma chain_empty [simp]: "chain {}"
  by (auto simp: chain_def)

lemma not_maxchain_Some: "chain C \<Longrightarrow> \<not> maxchain C \<Longrightarrow> C <c (SOME D. C <c D)"
  by (rule someI_ex) (auto simp: maxchain_def)

lemma suc_not_equals: "chain C \<Longrightarrow> \<not> maxchain C \<Longrightarrow> suc C \<noteq> C"
  using not_maxchain_Some by (auto simp: suc_def)

lemma subset_suc:
  assumes "X \<subseteq> Y"
  shows "X \<subseteq> suc Y"
  using assms by (rule subset_trans) (rule suc_subset)

text \<open>
  We build a set \<^term>\<open>\<C>\<close> that is closed under applications
  of \<^term>\<open>suc\<close> and contains the union of all its subsets.
\<close>
inductive_set suc_Union_closed ("\<C>")
  where
    suc: "X \<in> \<C> \<Longrightarrow> suc X \<in> \<C>"
  | Union [unfolded Pow_iff]: "X \<in> Pow \<C> \<Longrightarrow> \<Union>X \<in> \<C>"

text \<open>
  Since the empty set as well as the set itself is a subset of
  every set, \<^term>\<open>\<C>\<close> contains at least \<^term>\<open>{} \<in> \<C>\<close> and
  \<^term>\<open>\<Union>\<C> \<in> \<C>\<close>.
\<close>
lemma suc_Union_closed_empty: "{} \<in> \<C>"
  and suc_Union_closed_Union: "\<Union>\<C> \<in> \<C>"
  using Union [of "{}"] and Union [of "\<C>"] by simp_all

text \<open>Thus closure under \<^term>\<open>suc\<close> will hit a maximal chain
  eventually, as is shown below.\<close>

lemma suc_Union_closed_induct [consumes 1, case_names suc Union, induct pred: suc_Union_closed]:
  assumes "X \<in> \<C>"
    and "\<And>X. X \<in> \<C> \<Longrightarrow> Q X \<Longrightarrow> Q (suc X)"
    and "\<And>X. X \<subseteq> \<C> \<Longrightarrow> \<forall>x\<in>X. Q x \<Longrightarrow> Q (\<Union>X)"
  shows "Q X"
  using assms by induct blast+

lemma suc_Union_closed_cases [consumes 1, case_names suc Union, cases pred: suc_Union_closed]:
  assumes "X \<in> \<C>"
    and "\<And>Y. X = suc Y \<Longrightarrow> Y \<in> \<C> \<Longrightarrow> Q"
    and "\<And>Y. X = \<Union>Y \<Longrightarrow> Y \<subseteq> \<C> \<Longrightarrow> Q"
  shows "Q"
  using assms by cases simp_all

text \<open>On chains, \<^term>\<open>suc\<close> yields a chain.\<close>
lemma chain_suc:
  assumes "chain X"
  shows "chain (suc X)"
  using assms
  by (cases "\<not> chain X \<or> maxchain X") (force simp: suc_def dest: not_maxchain_Some)+

lemma chain_sucD:
  assumes "chain X"
  shows "suc X \<subseteq> A \<and> chain (suc X)"
proof -
  from \<open>chain X\<close> have *: "chain (suc X)"
    by (rule chain_suc)
  then have "suc X \<subseteq> A"
    unfolding chain_def by blast
  with * show ?thesis by blast
qed

lemma suc_Union_closed_total':
  assumes "X \<in> \<C>" and "Y \<in> \<C>"
    and *: "\<And>Z. Z \<in> \<C> \<Longrightarrow> Z \<subseteq> Y \<Longrightarrow> Z = Y \<or> suc Z \<subseteq> Y"
  shows "X \<subseteq> Y \<or> suc Y \<subseteq> X"
  using \<open>X \<in> \<C>\<close>
proof induct
  case (suc X)
  with * show ?case by (blast del: subsetI intro: subset_suc)
next
  case Union
  then show ?case by blast
qed

lemma suc_Union_closed_subsetD:
  assumes "Y \<subseteq> X" and "X \<in> \<C>" and "Y \<in> \<C>"
  shows "X = Y \<or> suc Y \<subseteq> X"
  using assms(2,3,1)
proof (induct arbitrary: Y)
  case (suc X)
  note * = \<open>\<And>Y. Y \<in> \<C> \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> X = Y \<or> suc Y \<subseteq> X\<close>
  with suc_Union_closed_total' [OF \<open>Y \<in> \<C>\<close> \<open>X \<in> \<C>\<close>]
  have "Y \<subseteq> X \<or> suc X \<subseteq> Y" by blast
  then show ?case
  proof
    assume "Y \<subseteq> X"
    with * and \<open>Y \<in> \<C>\<close> subset_suc show ?thesis
      by fastforce
  next
    assume "suc X \<subseteq> Y"
    with \<open>Y \<subseteq> suc X\<close> show ?thesis by blast
  qed
next
  case (Union X)
  show ?case
  proof (rule ccontr)
    assume "\<not> ?thesis"
    with \<open>Y \<subseteq> \<Union>X\<close> obtain x y z
      where "\<not> suc Y \<subseteq> \<Union>X"
        and "x \<in> X" and "y \<in> x" and "y \<notin> Y"
        and "z \<in> suc Y" and "\<forall>x\<in>X. z \<notin> x" by blast
    with \<open>X \<subseteq> \<C>\<close> have "x \<in> \<C>" by blast
    from Union and \<open>x \<in> X\<close> have *: "\<And>y. y \<in> \<C> \<Longrightarrow> y \<subseteq> x \<Longrightarrow> x = y \<or> suc y \<subseteq> x"
      by blast
    with suc_Union_closed_total' [OF \<open>Y \<in> \<C>\<close> \<open>x \<in> \<C>\<close>] have "Y \<subseteq> x \<or> suc x \<subseteq> Y"
      by blast
    then show False
    proof
      assume "Y \<subseteq> x"
      with * [OF \<open>Y \<in> \<C>\<close>] \<open>y \<in> x\<close> \<open>y \<notin> Y\<close> \<open>x \<in> X\<close> \<open>\<not> suc Y \<subseteq> \<Union>X\<close> show False
        by blast
    next
      assume "suc x \<subseteq> Y"
      with \<open>y \<notin> Y\<close> suc_subset \<open>y \<in> x\<close> show False by blast
    qed
  qed
qed

text \<open>The elements of \<^term>\<open>\<C>\<close> are totally ordered by the subset relation.\<close>
lemma suc_Union_closed_total:
  assumes "X \<in> \<C>" and "Y \<in> \<C>"
  shows "X \<subseteq> Y \<or> Y \<subseteq> X"
proof (cases "\<forall>Z\<in>\<C>. Z \<subseteq> Y \<longrightarrow> Z = Y \<or> suc Z \<subseteq> Y")
  case True
  with suc_Union_closed_total' [OF assms]
  have "X \<subseteq> Y \<or> suc Y \<subseteq> X" by blast
  with suc_subset [of Y] show ?thesis by blast
next
  case False
  then obtain Z where "Z \<in> \<C>" and "Z \<subseteq> Y" and "Z \<noteq> Y" and "\<not> suc Z \<subseteq> Y"
    by blast
  with suc_Union_closed_subsetD and \<open>Y \<in> \<C>\<close> show ?thesis
    by blast
qed

text \<open>Once we hit a fixed point w.r.t. \<^term>\<open>suc\<close>, all other elements
  of \<^term>\<open>\<C>\<close> are subsets of this fixed point.\<close>
lemma suc_Union_closed_suc:
  assumes "X \<in> \<C>" and "Y \<in> \<C>" and "suc Y = Y"
  shows "X \<subseteq> Y"
  using \<open>X \<in> \<C>\<close>
proof induct
  case (suc X)
  with \<open>Y \<in> \<C>\<close> and suc_Union_closed_subsetD have "X = Y \<or> suc X \<subseteq> Y"
    by blast
  then show ?case
    by (auto simp: \<open>suc Y = Y\<close>)
next
  case Union
  then show ?case by blast
qed

lemma eq_suc_Union:
  assumes "X \<in> \<C>"
  shows "suc X = X \<longleftrightarrow> X = \<Union>\<C>"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have "\<Union>\<C> \<subseteq> X"
    by (rule suc_Union_closed_suc [OF suc_Union_closed_Union \<open>X \<in> \<C>\<close>])
  with \<open>X \<in> \<C>\<close> show ?rhs
    by blast
next
  from \<open>X \<in> \<C>\<close> have "suc X \<in> \<C>" by (rule suc)
  then have "suc X \<subseteq> \<Union>\<C>" by blast
  moreover assume ?rhs
  ultimately have "suc X \<subseteq> X" by simp
  moreover have "X \<subseteq> suc X" by (rule suc_subset)
  ultimately show ?lhs ..
qed

lemma suc_in_carrier:
  assumes "X \<subseteq> A"
  shows "suc X \<subseteq> A"
  using assms
  by (cases "\<not> chain X \<or> maxchain X") (auto dest: chain_sucD)

lemma suc_Union_closed_in_carrier:
  assumes "X \<in> \<C>"
  shows "X \<subseteq> A"
  using assms
  by induct (auto dest: suc_in_carrier)

text \<open>All elements of \<^term>\<open>\<C>\<close> are chains.\<close>
lemma suc_Union_closed_chain:
  assumes "X \<in> \<C>"
  shows "chain X"
  using assms
proof induct
  case (suc X)
  then show ?case
    using not_maxchain_Some by (simp add: suc_def)
next
  case (Union X)
  then have "\<Union>X \<subseteq> A"
    by (auto dest: suc_Union_closed_in_carrier)
  moreover have "\<forall>x\<in>\<Union>X. \<forall>y\<in>\<Union>X. x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  proof (intro ballI)
    fix x y
    assume "x \<in> \<Union>X" and "y \<in> \<Union>X"
    then obtain u v where "x \<in> u" and "u \<in> X" and "y \<in> v" and "v \<in> X"
      by blast
    with Union have "u \<in> \<C>" and "v \<in> \<C>" and "chain u" and "chain v"
      by blast+
    with suc_Union_closed_total have "u \<subseteq> v \<or> v \<subseteq> u"
      by blast
    then show "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
    proof
      assume "u \<subseteq> v"
      from \<open>chain v\<close> show ?thesis
      proof (rule chain_total)
        show "y \<in> v" by fact
        show "x \<in> v" using \<open>u \<subseteq> v\<close> and \<open>x \<in> u\<close> by blast
      qed
    next
      assume "v \<subseteq> u"
      from \<open>chain u\<close> show ?thesis
      proof (rule chain_total)
        show "x \<in> u" by fact
        show "y \<in> u" using \<open>v \<subseteq> u\<close> and \<open>y \<in> v\<close> by blast
      qed
    qed
  qed
  ultimately show ?case unfolding chain_def ..
qed

subsubsection \<open>Hausdorff's Maximum Principle\<close>

text \<open>There exists a maximal totally ordered subset of \<open>A\<close>. (Note that we do not
  require \<open>A\<close> to be partially ordered.)\<close>

theorem Hausdorff: "\<exists>C. maxchain C"
proof -
  let ?M = "\<Union>\<C>"
  have "maxchain ?M"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "suc ?M \<noteq> ?M"
      using suc_not_equals and suc_Union_closed_chain [OF suc_Union_closed_Union] by simp
    moreover have "suc ?M = ?M"
      using eq_suc_Union [OF suc_Union_closed_Union] by simp
    ultimately show False by contradiction
  qed
  then show ?thesis by blast
qed

text \<open>Make notation \<^term>\<open>\<C>\<close> available again.\<close>
no_notation suc_Union_closed  ("\<C>")

lemma chain_extend: "chain C \<Longrightarrow> z \<in> A \<Longrightarrow> \<forall>x\<in>C. x \<sqsubseteq> z \<Longrightarrow> chain ({z} \<union> C)"
  unfolding chain_def by blast

lemma maxchain_imp_chain: "maxchain C \<Longrightarrow> chain C"
  by (simp add: maxchain_def)

end

text \<open>Hide constant \<^const>\<open>pred_on.suc_Union_closed\<close>, which was just needed
  for the proof of Hausforff's maximum principle.\<close>
hide_const pred_on.suc_Union_closed

lemma chain_mono:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q x y"
    and "pred_on.chain A P C"
  shows "pred_on.chain A Q C"
  using assms unfolding pred_on.chain_def by blast

subsubsection \<open>Results for the proper subset relation\<close>

interpretation subset: pred_on "A" "(\<subset>)" for A .

lemma subset_maxchain_max:
  assumes "subset.maxchain A C"
    and "X \<in> A"
    and "\<Union>C \<subseteq> X"
  shows "\<Union>C = X"
proof (rule ccontr)
  let ?C = "{X} \<union> C"
  from \<open>subset.maxchain A C\<close> have "subset.chain A C"
    and *: "\<And>S. subset.chain A S \<Longrightarrow> \<not> C \<subset> S"
    by (auto simp: subset.maxchain_def)
  moreover have "\<forall>x\<in>C. x \<subseteq> X" using \<open>\<Union>C \<subseteq> X\<close> by auto
  ultimately have "subset.chain A ?C"
    using subset.chain_extend [of A C X] and \<open>X \<in> A\<close> by auto
  moreover assume **: "\<Union>C \<noteq> X"
  moreover from ** have "C \<subset> ?C" using \<open>\<Union>C \<subseteq> X\<close> by auto
  ultimately show False using * by blast
qed

lemma subset_chain_def: "\<And>\<A>. subset.chain \<A> \<C> = (\<C> \<subseteq> \<A> \<and> (\<forall>X\<in>\<C>. \<forall>Y\<in>\<C>. X \<subseteq> Y \<or> Y \<subseteq> X))"
  by (auto simp: subset.chain_def)

lemma subset_chain_insert:
  "subset.chain \<A> (insert B \<B>) \<longleftrightarrow> B \<in> \<A> \<and> (\<forall>X\<in>\<B>. X \<subseteq> B \<or> B \<subseteq> X) \<and> subset.chain \<A> \<B>"
  by (fastforce simp add: subset_chain_def)

subsubsection \<open>Zorn's lemma\<close>

text \<open>If every chain has an upper bound, then there is a maximal set.\<close>
theorem subset_Zorn:
  assumes "\<And>C. subset.chain A C \<Longrightarrow> \<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U"
  shows "\<exists>M\<in>A. \<forall>X\<in>A. M \<subseteq> X \<longrightarrow> X = M"
proof -
  from subset.Hausdorff [of A] obtain M where "subset.maxchain A M" ..
  then have "subset.chain A M"
    by (rule subset.maxchain_imp_chain)
  with assms obtain Y where "Y \<in> A" and "\<forall>X\<in>M. X \<subseteq> Y"
    by blast
  moreover have "\<forall>X\<in>A. Y \<subseteq> X \<longrightarrow> Y = X"
  proof (intro ballI impI)
    fix X
    assume "X \<in> A" and "Y \<subseteq> X"
    show "Y = X"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      with \<open>Y \<subseteq> X\<close> have "\<not> X \<subseteq> Y" by blast
      from subset.chain_extend [OF \<open>subset.chain A M\<close> \<open>X \<in> A\<close>] and \<open>\<forall>X\<in>M. X \<subseteq> Y\<close>
      have "subset.chain A ({X} \<union> M)"
        using \<open>Y \<subseteq> X\<close> by auto
      moreover have "M \<subset> {X} \<union> M"
        using \<open>\<forall>X\<in>M. X \<subseteq> Y\<close> and \<open>\<not> X \<subseteq> Y\<close> by auto
      ultimately show False
        using \<open>subset.maxchain A M\<close> by (auto simp: subset.maxchain_def)
    qed
  qed
  ultimately show ?thesis by blast
qed

text \<open>Alternative version of Zorn's lemma for the subset relation.\<close>
lemma subset_Zorn':
  assumes "\<And>C. subset.chain A C \<Longrightarrow> \<Union>C \<in> A"
  shows "\<exists>M\<in>A. \<forall>X\<in>A. M \<subseteq> X \<longrightarrow> X = M"
proof -
  from subset.Hausdorff [of A] obtain M where "subset.maxchain A M" ..
  then have "subset.chain A M"
    by (rule subset.maxchain_imp_chain)
  with assms have "\<Union>M \<in> A" .
  moreover have "\<forall>Z\<in>A. \<Union>M \<subseteq> Z \<longrightarrow> \<Union>M = Z"
  proof (intro ballI impI)
    fix Z
    assume "Z \<in> A" and "\<Union>M \<subseteq> Z"
    with subset_maxchain_max [OF \<open>subset.maxchain A M\<close>]
      show "\<Union>M = Z" .
  qed
  ultimately show ?thesis by blast
qed

subsection \<open>Zorn's Lemma for Partial Orders\<close>

text \<open>Relate old to new definitions.\<close>

definition chain_subset :: "'a set set \<Rightarrow> bool"  ("chain\<^sub>\<subseteq>")  (* Define globally? In Set.thy? *)
  where "chain\<^sub>\<subseteq> C \<longleftrightarrow> (\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B \<or> B \<subseteq> A)"

definition chains :: "'a set set \<Rightarrow> 'a set set set"
  where "chains A = {C. C \<subseteq> A \<and> chain\<^sub>\<subseteq> C}"

definition Chains :: "('a \<times> 'a) set \<Rightarrow> 'a set set"  (* Define globally? In Relation.thy? *)
  where "Chains r = {C. \<forall>a\<in>C. \<forall>b\<in>C. (a, b) \<in> r \<or> (b, a) \<in> r}"

lemma chains_extend: "c \<in> chains S \<Longrightarrow> z \<in> S \<Longrightarrow> \<forall>x \<in> c. x \<subseteq> z \<Longrightarrow> {z} \<union> c \<in> chains S"
  for z :: "'a set"
  unfolding chains_def chain_subset_def by blast

lemma mono_Chains: "r \<subseteq> s \<Longrightarrow> Chains r \<subseteq> Chains s"
  unfolding Chains_def by blast

lemma chain_subset_alt_def: "chain\<^sub>\<subseteq> C = subset.chain UNIV C"
  unfolding chain_subset_def subset.chain_def by fast

lemma chains_alt_def: "chains A = {C. subset.chain A C}"
  by (simp add: chains_def chain_subset_alt_def subset.chain_def)

lemma Chains_subset: "Chains r \<subseteq> {C. pred_on.chain UNIV (\<lambda>x y. (x, y) \<in> r) C}"
  by (force simp add: Chains_def pred_on.chain_def)

lemma Chains_subset':
  assumes "refl r"
  shows "{C. pred_on.chain UNIV (\<lambda>x y. (x, y) \<in> r) C} \<subseteq> Chains r"
  using assms
  by (auto simp add: Chains_def pred_on.chain_def refl_on_def)

lemma Chains_alt_def:
  assumes "refl r"
  shows "Chains r = {C. pred_on.chain UNIV (\<lambda>x y. (x, y) \<in> r) C}"
  using assms Chains_subset Chains_subset' by blast

lemma Chains_relation_of:
  assumes "C \<in> Chains (relation_of P A)" shows "C \<subseteq> A"
  using assms unfolding Chains_def relation_of_def by auto

lemma pairwise_chain_Union:
  assumes P: "\<And>S. S \<in> \<C> \<Longrightarrow> pairwise R S" and "chain\<^sub>\<subseteq> \<C>"
  shows "pairwise R (\<Union>\<C>)"
  using \<open>chain\<^sub>\<subseteq> \<C>\<close> unfolding pairwise_def chain_subset_def
  by (blast intro: P [unfolded pairwise_def, rule_format])

lemma Zorn_Lemma: "\<forall>C\<in>chains A. \<Union>C \<in> A \<Longrightarrow> \<exists>M\<in>A. \<forall>X\<in>A. M \<subseteq> X \<longrightarrow> X = M"
  using subset_Zorn' [of A] by (force simp: chains_alt_def)

lemma Zorn_Lemma2: "\<forall>C\<in>chains A. \<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U \<Longrightarrow> \<exists>M\<in>A. \<forall>X\<in>A. M \<subseteq> X \<longrightarrow> X = M"
  using subset_Zorn [of A] by (auto simp: chains_alt_def)

subsection \<open>Other variants of Zorn's Lemma\<close>

lemma chainsD: "c \<in> chains S \<Longrightarrow> x \<in> c \<Longrightarrow> y \<in> c \<Longrightarrow> x \<subseteq> y \<or> y \<subseteq> x"
  unfolding chains_def chain_subset_def by blast

lemma chainsD2: "c \<in> chains S \<Longrightarrow> c \<subseteq> S"
  unfolding chains_def by blast

lemma Zorns_po_lemma:
  assumes po: "Partial_order r"
    and u: "\<And>C. C \<in> Chains r \<Longrightarrow> \<exists>u\<in>Field r. \<forall>a\<in>C. (a, u) \<in> r"
  shows "\<exists>m\<in>Field r. \<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
proof -
  have "Preorder r"
    using po by (simp add: partial_order_on_def)
  txt \<open>Mirror \<open>r\<close> in the set of subsets below (wrt \<open>r\<close>) elements of \<open>A\<close>.\<close>
  let ?B = "\<lambda>x. r\<inverse> `` {x}"
  let ?S = "?B ` Field r"
  have "\<exists>u\<in>Field r. \<forall>A\<in>C. A \<subseteq> r\<inverse> `` {u}"  (is "\<exists>u\<in>Field r. ?P u")
    if 1: "C \<subseteq> ?S" and 2: "\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B \<or> B \<subseteq> A" for C
  proof -
    let ?A = "{x\<in>Field r. \<exists>M\<in>C. M = ?B x}"
    from 1 have "C = ?B ` ?A" by (auto simp: image_def)
    have "?A \<in> Chains r"
    proof (simp add: Chains_def, intro allI impI, elim conjE)
      fix a b
      assume "a \<in> Field r" and "?B a \<in> C" and "b \<in> Field r" and "?B b \<in> C"
      with 2 have "?B a \<subseteq> ?B b \<or> ?B b \<subseteq> ?B a" by auto
      then show "(a, b) \<in> r \<or> (b, a) \<in> r"
        using \<open>Preorder r\<close> and \<open>a \<in> Field r\<close> and \<open>b \<in> Field r\<close>
        by (simp add:subset_Image1_Image1_iff)
    qed
    then obtain u where uA: "u \<in> Field r" "\<forall>a\<in>?A. (a, u) \<in> r"
      by (auto simp: dest: u)
    have "?P u"
    proof auto
      fix a B assume aB: "B \<in> C" "a \<in> B"
      with 1 obtain x where "x \<in> Field r" and "B = r\<inverse> `` {x}" by auto
      then show "(a, u) \<in> r"
        using uA and aB and \<open>Preorder r\<close>
        unfolding preorder_on_def refl_on_def by simp (fast dest: transD)
    qed
    then show ?thesis
      using \<open>u \<in> Field r\<close> by blast
  qed
  then have "\<forall>C\<in>chains ?S. \<exists>U\<in>?S. \<forall>A\<in>C. A \<subseteq> U"
    by (auto simp: chains_def chain_subset_def)
  from Zorn_Lemma2 [OF this] obtain m B
    where "m \<in> Field r"
      and "B = r\<inverse> `` {m}"
      and "\<forall>x\<in>Field r. B \<subseteq> r\<inverse> `` {x} \<longrightarrow> r\<inverse> `` {x} = B"
    by auto
  then have "\<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
    using po and \<open>Preorder r\<close> and \<open>m \<in> Field r\<close>
    by (auto simp: subset_Image1_Image1_iff Partial_order_eq_Image1_Image1_iff)
  then show ?thesis
    using \<open>m \<in> Field r\<close> by blast
qed

lemma predicate_Zorn:
  assumes po: "partial_order_on A (relation_of P A)"
    and ch: "\<And>C. C \<in> Chains (relation_of P A) \<Longrightarrow> \<exists>u \<in> A. \<forall>a \<in> C. P a u"
  shows "\<exists>m \<in> A. \<forall>a \<in> A. P m a \<longrightarrow> a = m"
proof -
  have "a \<in> A" if "C \<in> Chains (relation_of P A)" and "a \<in> C" for C a
    using that unfolding Chains_def relation_of_def by auto
  moreover have "(a, u) \<in> relation_of P A" if "a \<in> A" and "u \<in> A" and "P a u" for a u
    unfolding relation_of_def using that by auto
  ultimately have "\<exists>m\<in>A. \<forall>a\<in>A. (m, a) \<in> relation_of P A \<longrightarrow> a = m"
    using Zorns_po_lemma[OF Partial_order_relation_ofI[OF po], rule_format] ch
    unfolding Field_relation_of[OF partial_order_onD(1)[OF po]] by blast
  then show ?thesis
    by (auto simp: relation_of_def)
qed

lemma Union_in_chain: "\<lbrakk>finite \<B>; \<B> \<noteq> {}; subset.chain \<A> \<B>\<rbrakk> \<Longrightarrow> \<Union>\<B> \<in> \<B>"
proof (induction \<B> rule: finite_induct)
  case (insert B \<B>)
  show ?case
  proof (cases "\<B> = {}")
    case False
    then show ?thesis
      using insert sup.absorb2 by (auto simp: subset_chain_insert dest!: bspec [where x="\<Union>\<B>"])
  qed auto
qed simp

lemma Inter_in_chain: "\<lbrakk>finite \<B>; \<B> \<noteq> {}; subset.chain \<A> \<B>\<rbrakk> \<Longrightarrow> \<Inter>\<B> \<in> \<B>"
proof (induction \<B> rule: finite_induct)
  case (insert B \<B>)
  show ?case
  proof (cases "\<B> = {}")
    case False
    then show ?thesis
      using insert inf.absorb2 by (auto simp: subset_chain_insert dest!: bspec [where x="\<Inter>\<B>"])
  qed auto
qed simp

lemma finite_subset_Union_chain:
  assumes "finite A" "A \<subseteq> \<Union>\<B>" "\<B> \<noteq> {}" and sub: "subset.chain \<A> \<B>"
  obtains B where "B \<in> \<B>" "A \<subseteq> B"
proof -
  obtain \<F> where \<F>: "finite \<F>" "\<F> \<subseteq> \<B>" "A \<subseteq> \<Union>\<F>"
    using assms by (auto intro: finite_subset_Union)
  show thesis
  proof (cases "\<F> = {}")
    case True
    then show ?thesis
      using \<open>A \<subseteq> \<Union>\<F>\<close> \<open>\<B> \<noteq> {}\<close> that by fastforce
  next
    case False
    show ?thesis
    proof
      show "\<Union>\<F> \<in> \<B>"
        using sub \<open>\<F> \<subseteq> \<B>\<close> \<open>finite \<F>\<close>
        by (simp add: Union_in_chain False subset.chain_def subset_iff)
      show "A \<subseteq> \<Union>\<F>"
        using \<open>A \<subseteq> \<Union>\<F>\<close> by blast
    qed
  qed
qed

lemma subset_Zorn_nonempty:
  assumes "\<A> \<noteq> {}" and ch: "\<And>\<C>. \<lbrakk>\<C>\<noteq>{}; subset.chain \<A> \<C>\<rbrakk> \<Longrightarrow> \<Union>\<C> \<in> \<A>"
  shows "\<exists>M\<in>\<A>. \<forall>X\<in>\<A>. M \<subseteq> X \<longrightarrow> X = M"
proof (rule subset_Zorn)
  show "\<exists>U\<in>\<A>. \<forall>X\<in>\<C>. X \<subseteq> U" if "subset.chain \<A> \<C>" for \<C>
  proof (cases "\<C> = {}")
    case True
    then show ?thesis
      using \<open>\<A> \<noteq> {}\<close> by blast
  next
    case False
    show ?thesis
      by (blast intro!: ch False that Union_upper)
  qed
qed

subsection \<open>The Well Ordering Theorem\<close>

(* The initial segment of a relation appears generally useful.
   Move to Relation.thy?
   Definition correct/most general?
   Naming?
*)
definition init_seg_of :: "(('a \<times> 'a) set \<times> ('a \<times> 'a) set) set"
  where "init_seg_of = {(r, s). r \<subseteq> s \<and> (\<forall>a b c. (a, b) \<in> s \<and> (b, c) \<in> r \<longrightarrow> (a, b) \<in> r)}"

abbreviation initial_segment_of_syntax :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
    (infix "initial'_segment'_of" 55)
  where "r initial_segment_of s \<equiv> (r, s) \<in> init_seg_of"

lemma refl_on_init_seg_of [simp]: "r initial_segment_of r"
  by (simp add: init_seg_of_def)

lemma trans_init_seg_of:
  "r initial_segment_of s \<Longrightarrow> s initial_segment_of t \<Longrightarrow> r initial_segment_of t"
  by (simp (no_asm_use) add: init_seg_of_def) blast

lemma antisym_init_seg_of: "r initial_segment_of s \<Longrightarrow> s initial_segment_of r \<Longrightarrow> r = s"
  unfolding init_seg_of_def by safe

lemma Chains_init_seg_of_Union: "R \<in> Chains init_seg_of \<Longrightarrow> r\<in>R \<Longrightarrow> r initial_segment_of \<Union>R"
  by (auto simp: init_seg_of_def Ball_def Chains_def) blast

lemma chain_subset_trans_Union:
  assumes "chain\<^sub>\<subseteq> R" "\<forall>r\<in>R. trans r"
  shows "trans (\<Union>R)"
proof (intro transI, elim UnionE)
  fix S1 S2 :: "'a rel" and x y z :: 'a
  assume "S1 \<in> R" "S2 \<in> R"
  with assms(1) have "S1 \<subseteq> S2 \<or> S2 \<subseteq> S1"
    unfolding chain_subset_def by blast
  moreover assume "(x, y) \<in> S1" "(y, z) \<in> S2"
  ultimately have "((x, y) \<in> S1 \<and> (y, z) \<in> S1) \<or> ((x, y) \<in> S2 \<and> (y, z) \<in> S2)"
    by blast
  with \<open>S1 \<in> R\<close> \<open>S2 \<in> R\<close> assms(2) show "(x, z) \<in> \<Union>R"
    by (auto elim: transE)
qed

lemma chain_subset_antisym_Union:
  assumes "chain\<^sub>\<subseteq> R" "\<forall>r\<in>R. antisym r"
  shows "antisym (\<Union>R)"
proof (intro antisymI, elim UnionE)
  fix S1 S2 :: "'a rel" and x y :: 'a
  assume "S1 \<in> R" "S2 \<in> R"
  with assms(1) have "S1 \<subseteq> S2 \<or> S2 \<subseteq> S1"
    unfolding chain_subset_def by blast
  moreover assume "(x, y) \<in> S1" "(y, x) \<in> S2"
  ultimately have "((x, y) \<in> S1 \<and> (y, x) \<in> S1) \<or> ((x, y) \<in> S2 \<and> (y, x) \<in> S2)"
    by blast
  with \<open>S1 \<in> R\<close> \<open>S2 \<in> R\<close> assms(2) show "x = y"
    unfolding antisym_def by auto
qed

lemma chain_subset_Total_Union:
  assumes "chain\<^sub>\<subseteq> R" and "\<forall>r\<in>R. Total r"
  shows "Total (\<Union>R)"
proof (simp add: total_on_def Ball_def, auto del: disjCI)
  fix r s a b
  assume A: "r \<in> R" "s \<in> R" "a \<in> Field r" "b \<in> Field s" "a \<noteq> b"
  from \<open>chain\<^sub>\<subseteq> R\<close> and \<open>r \<in> R\<close> and \<open>s \<in> R\<close> have "r \<subseteq> s \<or> s \<subseteq> r"
    by (auto simp add: chain_subset_def)
  then show "(\<exists>r\<in>R. (a, b) \<in> r) \<or> (\<exists>r\<in>R. (b, a) \<in> r)"
  proof
    assume "r \<subseteq> s"
    then have "(a, b) \<in> s \<or> (b, a) \<in> s"
      using assms(2) A mono_Field[of r s]
      by (auto simp add: total_on_def)
    then show ?thesis
      using \<open>s \<in> R\<close> by blast
  next
    assume "s \<subseteq> r"
    then have "(a, b) \<in> r \<or> (b, a) \<in> r"
      using assms(2) A mono_Field[of s r]
      by (fastforce simp add: total_on_def)
    then show ?thesis
      using \<open>r \<in> R\<close> by blast
  qed
qed

lemma wf_Union_wf_init_segs:
  assumes "R \<in> Chains init_seg_of"
    and "\<forall>r\<in>R. wf r"
  shows "wf (\<Union>R)"
proof (simp add: wf_iff_no_infinite_down_chain, rule ccontr, auto)
  fix f
  assume 1: "\<forall>i. \<exists>r\<in>R. (f (Suc i), f i) \<in> r"
  then obtain r where "r \<in> R" and "(f (Suc 0), f 0) \<in> r" by auto
  have "(f (Suc i), f i) \<in> r" for i
  proof (induct i)
    case 0
    show ?case by fact
  next
    case (Suc i)
    then obtain s where s: "s \<in> R" "(f (Suc (Suc i)), f(Suc i)) \<in> s"
      using 1 by auto
    then have "s initial_segment_of r \<or> r initial_segment_of s"
      using assms(1) \<open>r \<in> R\<close> by (simp add: Chains_def)
    with Suc s show ?case by (simp add: init_seg_of_def) blast
  qed
  then show False
    using assms(2) and \<open>r \<in> R\<close>
    by (simp add: wf_iff_no_infinite_down_chain) blast
qed

lemma initial_segment_of_Diff: "p initial_segment_of q \<Longrightarrow> p - s initial_segment_of q - s"
  unfolding init_seg_of_def by blast

lemma Chains_inits_DiffI: "R \<in> Chains init_seg_of \<Longrightarrow> {r - s |r. r \<in> R} \<in> Chains init_seg_of"
  unfolding Chains_def by (blast intro: initial_segment_of_Diff)

theorem well_ordering: "\<exists>r::'a rel. Well_order r \<and> Field r = UNIV"
proof -
\<comment> \<open>The initial segment relation on well-orders:\<close>
  let ?WO = "{r::'a rel. Well_order r}"
  define I where "I = init_seg_of \<inter> ?WO \<times> ?WO"
  then have I_init: "I \<subseteq> init_seg_of" by simp
  then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
    unfolding init_seg_of_def chain_subset_def Chains_def by blast
  have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow> Well_order r"
    by (simp add: Chains_def I_def) blast
  have FI: "Field I = ?WO"
    by (auto simp add: I_def init_seg_of_def Field_def)
  then have 0: "Partial_order I"
    by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
        trans_def I_def elim!: trans_init_seg_of)
\<comment> \<open>\<open>I\<close>-chains have upper bounds in \<open>?WO\<close> wrt \<open>I\<close>: their Union\<close>
  have "\<Union>R \<in> ?WO \<and> (\<forall>r\<in>R. (r, \<Union>R) \<in> I)" if "R \<in> Chains I" for R
  proof -
    from that have Ris: "R \<in> Chains init_seg_of"
      using mono_Chains [OF I_init] by blast
    have subch: "chain\<^sub>\<subseteq> R"
      using \<open>R \<in> Chains I\<close> I_init by (auto simp: init_seg_of_def chain_subset_def Chains_def)
    have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r"
      and "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)"
      using Chains_wo [OF \<open>R \<in> Chains I\<close>] by (simp_all add: order_on_defs)
    have "Refl (\<Union>R)"
      using \<open>\<forall>r\<in>R. Refl r\<close> unfolding refl_on_def by fastforce
    moreover have "trans (\<Union>R)"
      by (rule chain_subset_trans_Union [OF subch \<open>\<forall>r\<in>R. trans r\<close>])
    moreover have "antisym (\<Union>R)"
      by (rule chain_subset_antisym_Union [OF subch \<open>\<forall>r\<in>R. antisym r\<close>])
    moreover have "Total (\<Union>R)"
      by (rule chain_subset_Total_Union [OF subch \<open>\<forall>r\<in>R. Total r\<close>])
    moreover have "wf ((\<Union>R) - Id)"
    proof -
      have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
      with \<open>\<forall>r\<in>R. wf (r - Id)\<close> and wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
      show ?thesis by fastforce
    qed
    ultimately have "Well_order (\<Union>R)"
      by (simp add:order_on_defs)
    moreover have "\<forall>r \<in> R. r initial_segment_of \<Union>R"
      using Ris by (simp add: Chains_init_seg_of_Union)
    ultimately show ?thesis
      using mono_Chains [OF I_init] Chains_wo[of R] and \<open>R \<in> Chains I\<close>
      unfolding I_def by blast
  qed
  then have 1: "\<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" if "R \<in> Chains I" for R
    using that by (subst FI) blast
\<comment> \<open>Zorn's Lemma yields a maximal well-order \<open>m\<close>:\<close>
  then obtain m :: "'a rel"
    where "Well_order m"
      and max: "\<forall>r. Well_order r \<and> (m, r) \<in> I \<longrightarrow> r = m"
    using Zorns_po_lemma[OF 0 1] unfolding FI by fastforce
\<comment> \<open>Now show by contradiction that \<open>m\<close> covers the whole type:\<close>
  have False if "x \<notin> Field m" for x :: 'a
  proof -
\<comment> \<open>Assuming that \<open>x\<close> is not covered and extend \<open>m\<close> at the top with \<open>x\<close>\<close>
    have "m \<noteq> {}"
    proof
      assume "m = {}"
      moreover have "Well_order {(x, x)}"
        by (simp add: order_on_defs refl_on_def trans_def antisym_def total_on_def Field_def)
      ultimately show False using max
        by (auto simp: I_def init_seg_of_def simp del: Field_insert)
    qed
    then have "Field m \<noteq> {}" by (auto simp: Field_def)
    moreover have "wf (m - Id)"
      using \<open>Well_order m\<close> by (simp add: well_order_on_def)
\<comment> \<open>The extension of \<open>m\<close> by \<open>x\<close>:\<close>
    let ?s = "{(a, x) | a. a \<in> Field m}"
    let ?m = "insert (x, x) m \<union> ?s"
    have Fm: "Field ?m = insert x (Field m)"
      by (auto simp: Field_def)
    have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
      using \<open>Well_order m\<close> by (simp_all add: order_on_defs)
\<comment> \<open>We show that the extension is a well-order\<close>
    have "Refl ?m"
      using \<open>Refl m\<close> Fm unfolding refl_on_def by blast
    moreover have "trans ?m" using \<open>trans m\<close> and \<open>x \<notin> Field m\<close>
      unfolding trans_def Field_def by blast
    moreover have "antisym ?m"
      using \<open>antisym m\<close> and \<open>x \<notin> Field m\<close> unfolding antisym_def Field_def by blast
    moreover have "Total ?m"
      using \<open>Total m\<close> and Fm by (auto simp: total_on_def)
    moreover have "wf (?m - Id)"
    proof -
      have "wf ?s"
        using \<open>x \<notin> Field m\<close> by (auto simp: wf_eq_minimal Field_def Bex_def)
      then show ?thesis
        using \<open>wf (m - Id)\<close> and \<open>x \<notin> Field m\<close> wf_subset [OF \<open>wf ?s\<close> Diff_subset]
        by (auto simp: Un_Diff Field_def intro: wf_Un)
    qed
    ultimately have "Well_order ?m"
      by (simp add: order_on_defs)
\<comment> \<open>We show that the extension is above \<open>m\<close>\<close>
    moreover have "(m, ?m) \<in> I"
      using \<open>Well_order ?m\<close> and \<open>Well_order m\<close> and \<open>x \<notin> Field m\<close>
      by (fastforce simp: I_def init_seg_of_def Field_def)
    ultimately
\<comment> \<open>This contradicts maximality of \<open>m\<close>:\<close>
    show False
      using max and \<open>x \<notin> Field m\<close> unfolding Field_def by blast
  qed
  then have "Field m = UNIV" by auto
  with \<open>Well_order m\<close> show ?thesis by blast
qed

corollary well_order_on: "\<exists>r::'a rel. well_order_on A r"
proof -
  obtain r :: "'a rel" where wo: "Well_order r" and univ: "Field r = UNIV"
    using well_ordering [where 'a = "'a"] by blast
  let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
  have 1: "Field ?r = A"
    using wo univ by (fastforce simp: Field_def order_on_defs refl_on_def)
  from \<open>Well_order r\<close> have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
    by (simp_all add: order_on_defs)
  from \<open>Refl r\<close> have "Refl ?r"
    by (auto simp: refl_on_def 1 univ)
  moreover from \<open>trans r\<close> have "trans ?r"
    unfolding trans_def by blast
  moreover from \<open>antisym r\<close> have "antisym ?r"
    unfolding antisym_def by blast
  moreover from \<open>Total r\<close> have "Total ?r"
    by (simp add:total_on_def 1 univ)
  moreover have "wf (?r - Id)"
    by (rule wf_subset [OF \<open>wf (r - Id)\<close>]) blast
  ultimately have "Well_order ?r"
    by (simp add: order_on_defs)
  with 1 show ?thesis by auto
qed

lemma dependent_wf_choice:
  fixes P :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes "wf R"
    and adm: "\<And>f g x r. (\<And>z. (z, x) \<in> R \<Longrightarrow> f z = g z) \<Longrightarrow> P f x r = P g x r"
    and P: "\<And>x f. (\<And>y. (y, x) \<in> R \<Longrightarrow> P f y (f y)) \<Longrightarrow> \<exists>r. P f x r"
  shows "\<exists>f. \<forall>x. P f x (f x)"
proof (intro exI allI)
  fix x
  define f where "f \<equiv> wfrec R (\<lambda>f x. SOME r. P f x r)"
  from \<open>wf R\<close> show "P f x (f x)"
  proof (induct x)
    case (less x)
    show "P f x (f x)"
    proof (subst (2) wfrec_def_adm[OF f_def \<open>wf R\<close>])
      show "adm_wf R (\<lambda>f x. SOME r. P f x r)"
        by (auto simp: adm_wf_def intro!: arg_cong[where f=Eps] adm)
      show "P f x (Eps (P f x))"
        using P by (rule someI_ex) fact
    qed
  qed
qed

lemma (in wellorder) dependent_wellorder_choice:
  assumes "\<And>r f g x. (\<And>y. y < x \<Longrightarrow> f y = g y) \<Longrightarrow> P f x r = P g x r"
    and P: "\<And>x f. (\<And>y. y < x \<Longrightarrow> P f y (f y)) \<Longrightarrow> \<exists>r. P f x r"
  shows "\<exists>f. \<forall>x. P f x (f x)"
  using wf by (rule dependent_wf_choice) (auto intro!: assms)

end


(*  Title:      HOL/Computational_Algebra/Primes.thy
    Author:     Christophe Tabacznyj
    Author:     Lawrence C. Paulson
    Author:     Amine Chaieb
    Author:     Thomas M. Rasmussen
    Author:     Jeremy Avigad
    Author:     Tobias Nipkow
    Author:     Manuel Eberl

This theory deals with properties of primes. Definitions and lemmas are
proved uniformly for the natural numbers and integers.

This file combines and revises a number of prior developments.

The original theories "GCD" and "Primes" were by Christophe Tabacznyj
and Lawrence C. Paulson, based on @{cite davenport92}. They introduced
gcd, lcm, and prime for the natural numbers.

The original theory "IntPrimes" was by Thomas M. Rasmussen, and
extended gcd, lcm, primes to the integers. Amine Chaieb provided
another extension of the notions to the integers, and added a number
of results to "Primes" and "GCD". IntPrimes also defined and developed
the congruence relations on the integers. The notion was extended to
the natural numbers by Chaieb.

Jeremy Avigad combined all of these, made everything uniform for the
natural numbers and the integers, and added a number of new theorems.

Tobias Nipkow cleaned up a lot.

Florian Haftmann and Manuel Eberl put primality and prime factorisation
onto an algebraic foundation and thus generalised these concepts to
other rings, such as polynomials. (see also the Factorial_Ring theory).

There were also previous formalisations of unique factorisation by
Thomas Marthedal Rasmussen, Jeremy Avigad, and David Gray.
*)

section \<open>Primes\<close>

theory Primes
imports Euclidean_Algorithm
begin

subsection \<open>Primes on \<^typ>\<open>nat\<close> and \<^typ>\<open>int\<close>\<close>

lemma Suc_0_not_prime_nat [simp]: "\<not> prime (Suc 0)"
  using not_prime_1 [where ?'a = nat] by simp

lemma prime_ge_2_nat:
  "p \<ge> 2" if "prime p" for p :: nat
proof -
  from that have "p \<noteq> 0" and "p \<noteq> 1"
    by (auto dest: prime_elem_not_zeroI prime_elem_not_unit)
  then show ?thesis
    by simp
qed

lemma prime_ge_2_int:
  "p \<ge> 2" if "prime p" for p :: int
proof -
  from that have "prime_elem p" and "\<bar>p\<bar> = p"
    by (auto dest: normalize_prime)
  then have "p \<noteq> 0" and "\<bar>p\<bar> \<noteq> 1" and "p \<ge> 0"
    by (auto dest: prime_elem_not_zeroI prime_elem_not_unit)
  then show ?thesis
    by simp
qed

lemma prime_ge_0_int: "prime p \<Longrightarrow> p \<ge> (0::int)"
  using prime_ge_2_int [of p] by simp

lemma prime_gt_0_nat: "prime p \<Longrightarrow> p > (0::nat)"
  using prime_ge_2_nat [of p] by simp

(* As a simp or intro rule,

     prime p \<Longrightarrow> p > 0

   wreaks havoc here. When the premise includes \<forall>x \<in># M. prime x, it
   leads to the backchaining

     x > 0
     prime x
     x \<in># M   which is, unfortunately,
     count M x > 0  FIXME no, this is obsolete
*)

lemma prime_gt_0_int: "prime p \<Longrightarrow> p > (0::int)"
  using prime_ge_2_int [of p] by simp

lemma prime_ge_1_nat: "prime p \<Longrightarrow> p \<ge> (1::nat)"
  using prime_ge_2_nat [of p] by simp

lemma prime_ge_Suc_0_nat: "prime p \<Longrightarrow> p \<ge> Suc 0"
  using prime_ge_1_nat [of p] by simp

lemma prime_ge_1_int: "prime p \<Longrightarrow> p \<ge> (1::int)"
  using prime_ge_2_int [of p] by simp

lemma prime_gt_1_nat: "prime p \<Longrightarrow> p > (1::nat)"
  using prime_ge_2_nat [of p] by simp

lemma prime_gt_Suc_0_nat: "prime p \<Longrightarrow> p > Suc 0"
  using prime_gt_1_nat [of p] by simp

lemma prime_gt_1_int: "prime p \<Longrightarrow> p > (1::int)"
  using prime_ge_2_int [of p] by simp

lemma prime_natI:
  "prime p" if "p \<ge> 2" and "\<And>m n. p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n" for p :: nat
  using that by (auto intro!: primeI prime_elemI)

lemma prime_intI:
  "prime p" if "p \<ge> 2" and "\<And>m n. p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n" for p :: int
  using that by (auto intro!: primeI prime_elemI)

lemma prime_elem_nat_iff [simp]:
  "prime_elem n \<longleftrightarrow> prime n" for n :: nat
  by (simp add: prime_def)

lemma prime_elem_iff_prime_abs [simp]:
  "prime_elem k \<longleftrightarrow> prime \<bar>k\<bar>" for k :: int
  by (auto intro: primeI)

lemma prime_nat_int_transfer [simp]:
  "prime (int n) \<longleftrightarrow> prime n" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "n \<ge> 2"
    by (auto dest: prime_ge_2_int)
  then show ?Q
  proof (rule prime_natI)
    fix r s
    assume "n dvd r * s"
    with of_nat_dvd_iff [of n "r * s"] have "int n dvd int r * int s"
      by simp
    with \<open>?P\<close> have "int n dvd int r \<or> int n dvd int s"
      using prime_dvd_mult_iff [of "int n" "int r" "int s"]
      by simp
    then show "n dvd r \<or> n dvd s"
      by simp
  qed
next
  assume ?Q
  then have "int n \<ge> 2"
    by (auto dest: prime_ge_2_nat)
  then show ?P
  proof (rule prime_intI)
    fix r s
    assume "int n dvd r * s"
    then have "n dvd nat \<bar>r * s\<bar>"
      by simp
    then have "n dvd nat \<bar>r\<bar> * nat \<bar>s\<bar>"
      by (simp add: nat_abs_mult_distrib)
    with \<open>?Q\<close> have "n dvd nat \<bar>r\<bar> \<or> n dvd nat \<bar>s\<bar>"
      using prime_dvd_mult_iff [of "n" "nat \<bar>r\<bar>" "nat \<bar>s\<bar>"]
      by simp
    then show "int n dvd r \<or> int n dvd s"
      by simp
  qed
qed

lemma prime_nat_iff_prime [simp]:
  "prime (nat k) \<longleftrightarrow> prime k"
proof (cases "k \<ge> 0")
  case True
  then show ?thesis
    using prime_nat_int_transfer [of "nat k"] by simp
next
  case False
  then show ?thesis
    by (auto dest: prime_ge_2_int)
qed

lemma prime_int_nat_transfer:
  "prime k \<longleftrightarrow> k \<ge> 0 \<and> prime (nat k)"
  by (auto dest: prime_ge_2_int)

lemma prime_nat_naiveI:
  "prime p" if "p \<ge> 2" and dvd: "\<And>n. n dvd p \<Longrightarrow> n = 1 \<or> n = p" for p :: nat
proof (rule primeI, rule prime_elemI)
  fix m n :: nat
  assume "p dvd m * n"
  then obtain r s where "p = r * s" "r dvd m" "s dvd n"
    by (blast dest: division_decomp)
  moreover have "r = 1 \<or> r = p"
    using \<open>r dvd m\<close> \<open>p = r * s\<close> dvd [of r] by simp
  ultimately show "p dvd m \<or> p dvd n"
    by auto
qed (use \<open>p \<ge> 2\<close> in simp_all)

lemma prime_int_naiveI:
  "prime p" if "p \<ge> 2" and dvd: "\<And>k. k dvd p \<Longrightarrow> \<bar>k\<bar> = 1 \<or> \<bar>k\<bar> = p" for p :: int
proof -
  from \<open>p \<ge> 2\<close> have "nat p \<ge> 2"
    by simp
  then have "prime (nat p)"
  proof (rule prime_nat_naiveI)
    fix n
    assume "n dvd nat p"
    with \<open>p \<ge> 2\<close> have "n dvd nat \<bar>p\<bar>"
      by simp
    then have "int n dvd p"
      by simp
    with dvd [of "int n"] show "n = 1 \<or> n = nat p"
      by auto
  qed
  then show ?thesis
    by simp
qed

lemma prime_nat_iff:
  "prime (n :: nat) \<longleftrightarrow> (1 < n \<and> (\<forall>m. m dvd n \<longrightarrow> m = 1 \<or> m = n))"
proof (safe intro!: prime_gt_1_nat)
  assume "prime n"
  then have *: "prime_elem n"
    by simp
  fix m assume m: "m dvd n" "m \<noteq> n"
  from * \<open>m dvd n\<close> have "n dvd m \<or> is_unit m"
    by (intro irreducibleD' prime_elem_imp_irreducible)
  with m show "m = 1" by (auto dest: dvd_antisym)
next
  assume "n > 1" "\<forall>m. m dvd n \<longrightarrow> m = 1 \<or> m = n"
  then show "prime n"
    using prime_nat_naiveI [of n] by auto
qed

lemma prime_int_iff:
  "prime (n::int) \<longleftrightarrow> (1 < n \<and> (\<forall>m. m \<ge> 0 \<and> m dvd n \<longrightarrow> m = 1 \<or> m = n))"
proof (intro iffI conjI allI impI; (elim conjE)?)
  assume *: "prime n"
  hence irred: "irreducible n" by (auto intro: prime_elem_imp_irreducible)
  from * have "n \<ge> 0" "n \<noteq> 0" "n \<noteq> 1"
    by (auto simp add: prime_ge_0_int)
  thus "n > 1" by presburger
  fix m assume "m dvd n" \<open>m \<ge> 0\<close>
  with irred have "m dvd 1 \<or> n dvd m" by (auto simp: irreducible_altdef)
  with \<open>m dvd n\<close> \<open>m \<ge> 0\<close> \<open>n > 1\<close> show "m = 1 \<or> m = n"
    using associated_iff_dvd[of m n] by auto
next
  assume n: "1 < n" "\<forall>m. m \<ge> 0 \<and> m dvd n \<longrightarrow> m = 1 \<or> m = n"
  hence "nat n > 1" by simp
  moreover have "\<forall>m. m dvd nat n \<longrightarrow> m = 1 \<or> m = nat n"
  proof (intro allI impI)
    fix m assume "m dvd nat n"
    with \<open>n > 1\<close> have "m dvd nat \<bar>n\<bar>"
      by simp
    then have "int m dvd n"
      by simp
    with n(2) have "int m = 1 \<or> int m = n"
      using of_nat_0_le_iff by blast
    thus "m = 1 \<or> m = nat n" by auto
  qed
  ultimately show "prime n"
    unfolding prime_int_nat_transfer prime_nat_iff by auto
qed

lemma prime_nat_not_dvd:
  assumes "prime p" "p > n" "n \<noteq> (1::nat)"
  shows   "\<not>n dvd p"
proof
  assume "n dvd p"
  from assms(1) have "irreducible p" by (simp add: prime_elem_imp_irreducible)
  from irreducibleD'[OF this \<open>n dvd p\<close>] \<open>n dvd p\<close> \<open>p > n\<close> assms show False
    by (cases "n = 0") (auto dest!: dvd_imp_le)
qed

lemma prime_int_not_dvd:
  assumes "prime p" "p > n" "n > (1::int)"
  shows   "\<not>n dvd p"
proof
  assume "n dvd p"
  from assms(1) have "irreducible p" by (auto intro: prime_elem_imp_irreducible)
  from irreducibleD'[OF this \<open>n dvd p\<close>] \<open>n dvd p\<close> \<open>p > n\<close> assms show False
    by (auto dest!: zdvd_imp_le)
qed

lemma prime_odd_nat: "prime p \<Longrightarrow> p > (2::nat) \<Longrightarrow> odd p"
  by (intro prime_nat_not_dvd) auto

lemma prime_odd_int: "prime p \<Longrightarrow> p > (2::int) \<Longrightarrow> odd p"
  by (intro prime_int_not_dvd) auto

lemma prime_int_altdef:
  "prime p = (1 < p \<and> (\<forall>m::int. m \<ge> 0 \<longrightarrow> m dvd p \<longrightarrow>
    m = 1 \<or> m = p))"
  unfolding prime_int_iff by blast

lemma not_prime_eq_prod_nat:
  assumes "m > 1" "\<not> prime (m::nat)"
  shows   "\<exists>n k. n = m * k \<and> 1 < m \<and> m < n \<and> 1 < k \<and> k < n"
  using assms irreducible_altdef[of m]
  by (auto simp: prime_elem_iff_irreducible irreducible_altdef)

subsection \<open>Largest exponent of a prime factor\<close>

text\<open>Possibly duplicates other material, but avoid the complexities of multisets.\<close>

lemma prime_power_cancel_less:
  assumes "prime p" and eq: "m * (p ^ k) = m' * (p ^ k')" and less: "k < k'" and "\<not> p dvd m"
  shows False
proof -
  obtain l where l: "k' = k + l" and "l > 0"
    using less less_imp_add_positive by auto
  have "m = m * (p ^ k) div (p ^ k)"
    using \<open>prime p\<close> by simp
  also have "\<dots> = m' * (p ^ k') div (p ^ k)"
    using eq by simp
  also have "\<dots> = m' * (p ^ l) * (p ^ k) div (p ^ k)"
    by (simp add: l mult.commute mult.left_commute power_add)
  also have "... = m' * (p ^ l)"
    using \<open>prime p\<close> by simp
  finally have "p dvd m"
    using \<open>l > 0\<close> by simp
  with assms show False
    by simp
qed

lemma prime_power_cancel:
  assumes "prime p" and eq: "m * (p ^ k) = m' * (p ^ k')" and "\<not> p dvd m" "\<not> p dvd m'"
  shows "k = k'"
  using prime_power_cancel_less [OF \<open>prime p\<close>] assms
  by (metis linorder_neqE_nat)

lemma prime_power_cancel2:
  assumes "prime p" "m * (p ^ k) = m' * (p ^ k')" "\<not> p dvd m" "\<not> p dvd m'"
  obtains "m = m'" "k = k'"
  using prime_power_cancel [OF assms] assms by auto

lemma prime_power_canonical:
  fixes m :: nat
  assumes "prime p" "m > 0"
  shows "\<exists>k n. \<not> p dvd n \<and> m = n * p ^ k"
using \<open>m > 0\<close>
proof (induction m rule: less_induct)
  case (less m)
  show ?case
  proof (cases "p dvd m")
    case True
    then obtain m' where m': "m = p * m'"
      using dvdE by blast
    with \<open>prime p\<close> have "0 < m'" "m' < m"
      using less.prems prime_nat_iff by auto
    with m' less show ?thesis
      by (metis power_Suc mult.left_commute)
  next
    case False
    then show ?thesis
      by (metis mult.right_neutral power_0)
  qed
qed

subsubsection \<open>Make prime naively executable\<close>

lemma prime_nat_iff':
  "prime (p :: nat) \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {2..<p}. \<not> n dvd p)"
proof safe
  assume "p > 1" and *: "\<forall>n\<in>{2..<p}. \<not>n dvd p"
  show "prime p" unfolding prime_nat_iff
  proof (intro conjI allI impI)
    fix m assume "m dvd p"
    with \<open>p > 1\<close> have "m \<noteq> 0" by (intro notI) auto
    hence "m \<ge> 1" by simp
    moreover from \<open>m dvd p\<close> and * have "m \<notin> {2..<p}" by blast
    with \<open>m dvd p\<close> and \<open>p > 1\<close> have "m \<le> 1 \<or> m = p" by (auto dest: dvd_imp_le)
    ultimately show "m = 1 \<or> m = p" by simp
  qed fact+
qed (auto simp: prime_nat_iff)

lemma prime_int_iff':
  "prime (p :: int) \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {2..<p}. \<not> n dvd p)" (is "?P \<longleftrightarrow> ?Q")
proof (cases "p \<ge> 0")
  case True
  have "?P \<longleftrightarrow> prime (nat p)"
    by simp
  also have "\<dots> \<longleftrightarrow> p > 1 \<and> (\<forall>n\<in>{2..<nat p}. \<not> n dvd nat \<bar>p\<bar>)"
    using True by (simp add: prime_nat_iff')
  also have "{2..<nat p} = nat ` {2..<p}"
    using True int_eq_iff by fastforce
  finally show "?P \<longleftrightarrow> ?Q" by simp
next
  case False
  then show ?thesis
    by (auto simp add: prime_ge_0_int)
qed

lemma prime_int_numeral_eq [simp]:
  "prime (numeral m :: int) \<longleftrightarrow> prime (numeral m :: nat)"
  by (simp add: prime_int_nat_transfer)

lemma two_is_prime_nat [simp]: "prime (2::nat)"
  by (simp add: prime_nat_iff')

lemma prime_nat_numeral_eq [simp]:
  "prime (numeral m :: nat) \<longleftrightarrow>
    (1::nat) < numeral m \<and>
    (\<forall>n::nat \<in> set [2..<numeral m]. \<not> n dvd numeral m)"
  by (simp only: prime_nat_iff' set_upt)  \<comment> \<open>TODO Sieve Of Erathosthenes might speed this up\<close>

text\<open>A bit of regression testing:\<close>

lemma "prime(97::nat)" by simp
lemma "prime(97::int)" by simp

lemma prime_factor_nat:
  "n \<noteq> (1::nat) \<Longrightarrow> \<exists>p. prime p \<and> p dvd n"
  using prime_divisor_exists[of n]
  by (cases "n = 0") (auto intro: exI[of _ "2::nat"])

lemma prime_factor_int:
  fixes k :: int
  assumes "\<bar>k\<bar> \<noteq> 1"
  obtains p where "prime p" "p dvd k"
proof (cases "k = 0")
  case True
  then have "prime (2::int)" and "2 dvd k"
    by simp_all
  with that show thesis
    by blast
next
  case False
  with assms prime_divisor_exists [of k] obtain p where "prime p" "p dvd k"
    by auto
  with that show thesis
    by blast
qed

subsection \<open>Infinitely many primes\<close>

lemma next_prime_bound: "\<exists>p::nat. prime p \<and> n < p \<and> p \<le> fact n + 1"
proof-
  have f1: "fact n + 1 \<noteq> (1::nat)" using fact_ge_1 [of n, where 'a=nat] by arith
  from prime_factor_nat [OF f1]
  obtain p :: nat where "prime p" and "p dvd fact n + 1" by auto
  then have "p \<le> fact n + 1" apply (intro dvd_imp_le) apply auto done
  { assume "p \<le> n"
    from \<open>prime p\<close> have "p \<ge> 1"
      by (cases p, simp_all)
    with \<open>p <= n\<close> have "p dvd fact n"
      by (intro dvd_fact)
    with \<open>p dvd fact n + 1\<close> have "p dvd fact n + 1 - fact n"
      by (rule dvd_diff_nat)
    then have "p dvd 1" by simp
    then have "p <= 1" by auto
    moreover from \<open>prime p\<close> have "p > 1"
      using prime_nat_iff by blast
    ultimately have False by auto}
  then have "n < p" by presburger
  with \<open>prime p\<close> and \<open>p <= fact n + 1\<close> show ?thesis by auto
qed

lemma bigger_prime: "\<exists>p. prime p \<and> p > (n::nat)"
  using next_prime_bound by auto

lemma primes_infinite: "\<not> (finite {(p::nat). prime p})"
proof
  assume "finite {(p::nat). prime p}"
  with Max_ge have "(\<exists>b. (\<forall>x \<in> {(p::nat). prime p}. x \<le> b))"
    by auto
  then obtain b where "\<forall>(x::nat). prime x \<longrightarrow> x \<le> b"
    by auto
  with bigger_prime [of b] show False
    by auto
qed

subsection \<open>Powers of Primes\<close>

text\<open>Versions for type nat only\<close>

lemma prime_product:
  fixes p::nat
  assumes "prime (p * q)"
  shows "p = 1 \<or> q = 1"
proof -
  from assms have
    "1 < p * q" and P: "\<And>m. m dvd p * q \<Longrightarrow> m = 1 \<or> m = p * q"
    unfolding prime_nat_iff by auto
  from \<open>1 < p * q\<close> have "p \<noteq> 0" by (cases p) auto
  then have Q: "p = p * q \<longleftrightarrow> q = 1" by auto
  have "p dvd p * q" by simp
  then have "p = 1 \<or> p = p * q" by (rule P)
  then show ?thesis by (simp add: Q)
qed

(* TODO: Generalise? *)
lemma prime_power_mult_nat:
  fixes p :: nat
  assumes p: "prime p" and xy: "x * y = p ^ k"
  shows "\<exists>i j. x = p ^ i \<and> y = p^ j"
using xy
proof(induct k arbitrary: x y)
  case 0 thus ?case apply simp by (rule exI[where x="0"], simp)
next
  case (Suc k x y)
  from Suc.prems have pxy: "p dvd x*y" by auto
  from prime_dvd_multD [OF p pxy] have pxyc: "p dvd x \<or> p dvd y" .
  from p have p0: "p \<noteq> 0" by - (rule ccontr, simp)
  {assume px: "p dvd x"
    then obtain d where d: "x = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*y = p^Suc k" by simp
    hence th: "d*y = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "y = p^j" by blast
    with d have "x = p^Suc i" by simp
    with ij(2) have ?case by blast}
  moreover
  {assume px: "p dvd y"
    then obtain d where d: "y = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*x = p^Suc k" by (simp add: mult.commute)
    hence th: "d*x = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "x = p^j" by blast
    with d have "y = p^Suc i" by simp
    with ij(2) have ?case by blast}
  ultimately show ?case  using pxyc by blast
qed

lemma prime_power_exp_nat:
  fixes p::nat
  assumes p: "prime p" and n: "n \<noteq> 0"
    and xn: "x^n = p^k" shows "\<exists>i. x = p^i"
  using n xn
proof(induct n arbitrary: k)
  case 0 thus ?case by simp
next
  case (Suc n k) hence th: "x*x^n = p^k" by simp
  {assume "n = 0" with Suc have ?case by simp (rule exI[where x="k"], simp)}
  moreover
  {assume n: "n \<noteq> 0"
    from prime_power_mult_nat[OF p th]
    obtain i j where ij: "x = p^i" "x^n = p^j"by blast
    from Suc.hyps[OF n ij(2)] have ?case .}
  ultimately show ?case by blast
qed

lemma divides_primepow_nat:
  fixes p :: nat
  assumes p: "prime p"
  shows "d dvd p ^ k \<longleftrightarrow> (\<exists>i\<le>k. d = p ^ i)"
  using assms divides_primepow [of p d k] by (auto intro: le_imp_power_dvd)

subsection \<open>Chinese Remainder Theorem Variants\<close>

lemma bezout_gcd_nat:
  fixes a::nat shows "\<exists>x y. a * x - b * y = gcd a b \<or> b * x - a * y = gcd a b"
  using bezout_nat[of a b]
by (metis bezout_nat diff_add_inverse gcd_add_mult gcd.commute
  gcd_nat.right_neutral mult_0)

lemma gcd_bezout_sum_nat:
  fixes a::nat
  assumes "a * x + b * y = d"
  shows "gcd a b dvd d"
proof-
  let ?g = "gcd a b"
    have dv: "?g dvd a*x" "?g dvd b * y"
      by simp_all
    from dvd_add[OF dv] assms
    show ?thesis by auto
qed

text \<open>A binary form of the Chinese Remainder Theorem.\<close>

(* TODO: Generalise? *)
lemma chinese_remainder:
  fixes a::nat  assumes ab: "coprime a b" and a: "a \<noteq> 0" and b: "b \<noteq> 0"
  shows "\<exists>x q1 q2. x = u + q1 * a \<and> x = v + q2 * b"
proof-
  from bezout_add_strong_nat[OF a, of b] bezout_add_strong_nat[OF b, of a]
  obtain d1 x1 y1 d2 x2 y2 where dxy1: "d1 dvd a" "d1 dvd b" "a * x1 = b * y1 + d1"
    and dxy2: "d2 dvd b" "d2 dvd a" "b * x2 = a * y2 + d2" by blast
  then have d12: "d1 = 1" "d2 = 1"
    using ab coprime_common_divisor_nat [of a b] by blast+
  let ?x = "v * a * x1 + u * b * x2"
  let ?q1 = "v * x1 + u * y2"
  let ?q2 = "v * y1 + u * x2"
  from dxy2(3)[simplified d12] dxy1(3)[simplified d12]
  have "?x = u + ?q1 * a" "?x = v + ?q2 * b"
    by algebra+
  thus ?thesis by blast
qed

text \<open>Primality\<close>

lemma coprime_bezout_strong:
  fixes a::nat assumes "coprime a b"  "b \<noteq> 1"
  shows "\<exists>x y. a * x = b * y + 1"
  by (metis add.commute add.right_neutral assms(1) assms(2) chinese_remainder coprime_1_left coprime_1_right coprime_crossproduct_nat mult.commute mult.right_neutral mult_cancel_left)

lemma bezout_prime:
  assumes p: "prime p" and pa: "\<not> p dvd a"
  shows "\<exists>x y. a*x = Suc (p*y)"
proof -
  have ap: "coprime a p"
    using coprime_commute p pa prime_imp_coprime by auto
  moreover from p have "p \<noteq> 1" by auto
  ultimately have "\<exists>x y. a * x = p * y + 1"
    by (rule coprime_bezout_strong)
  then show ?thesis by simp
qed
(* END TODO *)

subsection \<open>Multiplicity and primality for natural numbers and integers\<close>

lemma prime_factors_gt_0_nat:
  "p \<in> prime_factors x \<Longrightarrow> p > (0::nat)"
  by (simp add: in_prime_factors_imp_prime prime_gt_0_nat)

lemma prime_factors_gt_0_int:
  "p \<in> prime_factors x \<Longrightarrow> p > (0::int)"
  by (simp add: in_prime_factors_imp_prime prime_gt_0_int)

lemma prime_factors_ge_0_int [elim]: (* FIXME !? *)
  fixes n :: int
  shows "p \<in> prime_factors n \<Longrightarrow> p \<ge> 0"
  by (drule prime_factors_gt_0_int) simp

lemma prod_mset_prime_factorization_int:
  fixes n :: int
  assumes "n > 0"
  shows   "prod_mset (prime_factorization n) = n"
  using assms by (simp add: prod_mset_prime_factorization)

lemma prime_factorization_exists_nat:
  "n > 0 \<Longrightarrow> (\<exists>M. (\<forall>p::nat \<in> set_mset M. prime p) \<and> n = (\<Prod>i \<in># M. i))"
  using prime_factorization_exists[of n] by auto

lemma prod_mset_prime_factorization_nat [simp]:
  "(n::nat) > 0 \<Longrightarrow> prod_mset (prime_factorization n) = n"
  by (subst prod_mset_prime_factorization) simp_all

lemma prime_factorization_nat:
    "n > (0::nat) \<Longrightarrow> n = (\<Prod>p \<in> prime_factors n. p ^ multiplicity p n)"
  by (simp add: prod_prime_factors)

lemma prime_factorization_int:
    "n > (0::int) \<Longrightarrow> n = (\<Prod>p \<in> prime_factors n. p ^ multiplicity p n)"
  by (simp add: prod_prime_factors)

lemma prime_factorization_unique_nat:
  fixes f :: "nat \<Rightarrow> _"
  assumes S_eq: "S = {p. 0 < f p}"
    and "finite S"
    and S: "\<forall>p\<in>S. prime p" "n = (\<Prod>p\<in>S. p ^ f p)"
  shows "S = prime_factors n \<and> (\<forall>p. prime p \<longrightarrow> f p = multiplicity p n)"
  using assms by (intro prime_factorization_unique'') auto

lemma prime_factorization_unique_int:
  fixes f :: "int \<Rightarrow> _"
  assumes S_eq: "S = {p. 0 < f p}"
    and "finite S"
    and S: "\<forall>p\<in>S. prime p" "abs n = (\<Prod>p\<in>S. p ^ f p)"
  shows "S = prime_factors n \<and> (\<forall>p. prime p \<longrightarrow> f p = multiplicity p n)"
  using assms by (intro prime_factorization_unique'') auto

lemma prime_factors_characterization_nat:
  "S = {p. 0 < f (p::nat)} \<Longrightarrow>
    finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> prime_factors n = S"
  by (rule prime_factorization_unique_nat [THEN conjunct1, symmetric])

lemma prime_factors_characterization'_nat:
  "finite {p. 0 < f (p::nat)} \<Longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
      prime_factors (\<Prod>p | 0 < f p. p ^ f p) = {p. 0 < f p}"
  by (rule prime_factors_characterization_nat) auto

lemma prime_factors_characterization_int:
  "S = {p. 0 < f (p::int)} \<Longrightarrow> finite S \<Longrightarrow>
    \<forall>p\<in>S. prime p \<Longrightarrow> abs n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> prime_factors n = S"
  by (rule prime_factorization_unique_int [THEN conjunct1, symmetric])

(* TODO Move *)
lemma abs_prod: "abs (prod f A :: 'a :: linordered_idom) = prod (\<lambda>x. abs (f x)) A"
  by (cases "finite A", induction A rule: finite_induct) (simp_all add: abs_mult)

lemma primes_characterization'_int [rule_format]:
  "finite {p. p \<ge> 0 \<and> 0 < f (p::int)} \<Longrightarrow> \<forall>p. 0 < f p \<longrightarrow> prime p \<Longrightarrow>
      prime_factors (\<Prod>p | p \<ge> 0 \<and> 0 < f p. p ^ f p) = {p. p \<ge> 0 \<and> 0 < f p}"
  by (rule prime_factors_characterization_int) (auto simp: abs_prod prime_ge_0_int)

lemma multiplicity_characterization_nat:
  "S = {p. 0 < f (p::nat)} \<Longrightarrow> finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow>
    n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> multiplicity p n = f p"
  by (frule prime_factorization_unique_nat [of S f n, THEN conjunct2, rule_format, symmetric]) auto

lemma multiplicity_characterization'_nat: "finite {p. 0 < f (p::nat)} \<longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<longrightarrow> prime p \<longrightarrow>
      multiplicity p (\<Prod>p | 0 < f p. p ^ f p) = f p"
  by (intro impI, rule multiplicity_characterization_nat) auto

lemma multiplicity_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
    finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow> n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> multiplicity p n = f p"
  by (frule prime_factorization_unique_int [of S f n, THEN conjunct2, rule_format, symmetric])
     (auto simp: abs_prod power_abs prime_ge_0_int intro!: prod.cong)

lemma multiplicity_characterization'_int [rule_format]:
  "finite {p. p \<ge> 0 \<and> 0 < f (p::int)} \<Longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow> prime p \<Longrightarrow>
      multiplicity p (\<Prod>p | p \<ge> 0 \<and> 0 < f p. p ^ f p) = f p"
  by (rule multiplicity_characterization_int) (auto simp: prime_ge_0_int)

lemma multiplicity_one_nat [simp]: "multiplicity p (Suc 0) = 0"
  unfolding One_nat_def [symmetric] by (rule multiplicity_one)

lemma multiplicity_eq_nat:
  fixes x and y::nat
  assumes "x > 0" "y > 0" "\<And>p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  using multiplicity_eq_imp_eq[of x y] assms by simp

lemma multiplicity_eq_int:
  fixes x y :: int
  assumes "x > 0" "y > 0" "\<And>p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  using multiplicity_eq_imp_eq[of x y] assms by simp

lemma multiplicity_prod_prime_powers:
  assumes "finite S" "\<And>x. x \<in> S \<Longrightarrow> prime x" "prime p"
  shows   "multiplicity p (\<Prod>p \<in> S. p ^ f p) = (if p \<in> S then f p else 0)"
proof -
  define g where "g = (\<lambda>x. if x \<in> S then f x else 0)"
  define A where "A = Abs_multiset g"
  have "{x. g x > 0} \<subseteq> S" by (auto simp: g_def)
  from finite_subset[OF this assms(1)] have [simp]: "finite {x. 0 < g x}"
    by simp
  from assms have count_A: "count A x = g x" for x unfolding A_def
    by simp
  have set_mset_A: "set_mset A = {x\<in>S. f x > 0}"
    unfolding set_mset_def count_A by (auto simp: g_def)
  with assms have prime: "prime x" if "x \<in># A" for x using that by auto
  from set_mset_A assms have "(\<Prod>p \<in> S. p ^ f p) = (\<Prod>p \<in> S. p ^ g p) "
    by (intro prod.cong) (auto simp: g_def)
  also from set_mset_A assms have "\<dots> = (\<Prod>p \<in> set_mset A. p ^ g p)"
    by (intro prod.mono_neutral_right) (auto simp: g_def set_mset_A)
  also have "\<dots> = prod_mset A"
    by (auto simp: prod_mset_multiplicity count_A set_mset_A intro!: prod.cong)
  also from assms have "multiplicity p \<dots> = sum_mset (image_mset (multiplicity p) A)"
    by (subst prime_elem_multiplicity_prod_mset_distrib) (auto dest: prime)
  also from assms have "image_mset (multiplicity p) A = image_mset (\<lambda>x. if x = p then 1 else 0) A"
    by (intro image_mset_cong) (auto simp: prime_multiplicity_other dest: prime)
  also have "sum_mset \<dots> = (if p \<in> S then f p else 0)" by (simp add: sum_mset_delta count_A g_def)
  finally show ?thesis .
qed

lemma prime_factorization_prod_mset:
  assumes "0 \<notin># A"
  shows "prime_factorization (prod_mset A) = \<Sum>\<^sub>#(image_mset prime_factorization A)"
  using assms by (induct A) (auto simp add: prime_factorization_mult)

lemma prime_factors_prod:
  assumes "finite A" and "0 \<notin> f ` A"
  shows "prime_factors (prod f A) = \<Union>((prime_factors \<circ> f) ` A)"
  using assms by (simp add: prod_unfold_prod_mset prime_factorization_prod_mset)

lemma prime_factors_fact:
  "prime_factors (fact n) = {p \<in> {2..n}. prime p}" (is "?M = ?N")
proof (rule set_eqI)
  fix p
  { fix m :: nat
    assume "p \<in> prime_factors m"
    then have "prime p" and "p dvd m" by auto
    moreover assume "m > 0"
    ultimately have "2 \<le> p" and "p \<le> m"
      by (auto intro: prime_ge_2_nat dest: dvd_imp_le)
    moreover assume "m \<le> n"
    ultimately have "2 \<le> p" and "p \<le> n"
      by (auto intro: order_trans)
  } note * = this
  show "p \<in> ?M \<longleftrightarrow> p \<in> ?N"
    by (auto simp add: fact_prod prime_factors_prod Suc_le_eq dest!: prime_prime_factors intro: *)
qed

lemma prime_dvd_fact_iff:
  assumes "prime p"
  shows "p dvd fact n \<longleftrightarrow> p \<le> n"
  using assms
  by (auto simp add: prime_factorization_subset_iff_dvd [symmetric]
    prime_factorization_prime prime_factors_fact prime_ge_2_nat)

(* TODO Legacy names *)
lemmas prime_imp_coprime_nat = prime_imp_coprime[where ?'a = nat]
lemmas prime_imp_coprime_int = prime_imp_coprime[where ?'a = int]
lemmas prime_dvd_mult_nat = prime_dvd_mult_iff[where ?'a = nat]
lemmas prime_dvd_mult_int = prime_dvd_mult_iff[where ?'a = int]
lemmas prime_dvd_mult_eq_nat = prime_dvd_mult_iff[where ?'a = nat]
lemmas prime_dvd_mult_eq_int = prime_dvd_mult_iff[where ?'a = int]
lemmas prime_dvd_power_nat = prime_dvd_power[where ?'a = nat]
lemmas prime_dvd_power_int = prime_dvd_power[where ?'a = int]
lemmas prime_dvd_power_nat_iff = prime_dvd_power_iff[where ?'a = nat]
lemmas prime_dvd_power_int_iff = prime_dvd_power_iff[where ?'a = int]
lemmas prime_imp_power_coprime_nat = prime_imp_power_coprime[where ?'a = nat]
lemmas prime_imp_power_coprime_int = prime_imp_power_coprime[where ?'a = int]
lemmas primes_coprime_nat = primes_coprime[where ?'a = nat]
lemmas primes_coprime_int = primes_coprime[where ?'a = nat]
lemmas prime_divprod_pow_nat = prime_elem_divprod_pow[where ?'a = nat]
lemmas prime_exp = prime_elem_power_iff[where ?'a = nat]

text \<open>Code generation\<close>

context
begin

qualified definition prime_nat :: "nat \<Rightarrow> bool"
  where [simp, code_abbrev]: "prime_nat = prime"

lemma prime_nat_naive [code]:
  "prime_nat p \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in>{1<..<p}. \<not> n dvd p)"
  by (auto simp add: prime_nat_iff')

qualified definition prime_int :: "int \<Rightarrow> bool"
  where [simp, code_abbrev]: "prime_int = prime"

lemma prime_int_naive [code]:
  "prime_int p \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in>{1<..<p}. \<not> n dvd p)"
  by (auto simp add: prime_int_iff')

lemma "prime(997::nat)" by eval

lemma "prime(997::int)" by eval

end

end


theory count
imports Main
begin

datatype nat = zero | s nat
datatype lst = nil | cons nat lst

inductive leq :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
zero: "leq zero n" |
step: "leq n m \<Longrightarrow> leq (s n) (s m)"

fun leq_fn :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"leq_fn zero n = True" |
"leq_fn (s m) zero = False" |
"leq_fn (s m) (s n) = leq_fn m n"

declare leq.intros[simp,intro]

fun length :: "lst \<Rightarrow> nat" where
"length nil = zero" |
"length (cons x xs) = s (length xs)"

fun count :: "(nat \<Rightarrow> bool) \<Rightarrow> lst \<Rightarrow> nat" where
"count p nil = zero" |
"count p (cons y ys) = (if (p y) then s (count p ys) else count p ys)"

lemma leq_s_right: "\<And>n. \<And>m. leq n m \<Longrightarrow> leq n (s m)"
proof -
fix n
show "\<And>m. leq n m \<Longrightarrow> leq n (s m)" proof(induct n)
case zero
then show ?case by simp
next
case (s n)
then show ?case by (metis nat.inject leq.simps)
qed
qed

lemma leq_fn_s_right: "\<And>n. \<And>m. leq_fn n m \<Longrightarrow> leq_fn n (s m)"
proof -
fix n
show "\<And>m. leq_fn n m \<Longrightarrow> leq_fn n (s m)" proof(induct n)
case zero
then show ?case by simp
next
case (s n)
then show ?case by (metis leq_fn.elims(2) leq_fn.simps(1) leq_fn.simps(3))
qed
qed

theorem "\<And>p. \<And>xs. leq (count p xs) (length xs)" proof -
fix xs
show "\<And>p. leq (count p xs) (length xs)" proof(induct xs)
case nil
then show ?case by simp
next
case (cons y ys)
then show ?case by (simp add: leq_s_right)
qed
qed

theorem "\<And>xs. \<And>x. leq_fn (count x xs) (length xs)" proof -
fix xs
show "\<And>x. leq_fn (count x xs) (length xs)" proof(induct xs)
case nil
then show ?case by simp
next
case (cons y ys)
then show ?case by (simp add: leq_fn_s_right)
qed
qed

end


(* Title: Block_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open>Block and Balanced Designs\<close>
text \<open>We define a selection of the many different types of block and balanced designs, building up
to properties required for defining a BIBD, in addition to several base generalisations\<close>

theory Block_Designs imports Design_Operations
begin

subsection \<open>Block Designs\<close>
text \<open>A block design is a design where all blocks have the same size.\<close>

subsubsection \<open>K Block Designs\<close>
text \<open>An important generalisation of a typical block design is the $\mathcal{K}$ block design,
where all blocks must have a size $x$ where $x \in \mathcal{K}$\<close>
locale K_block_design = proper_design +
  fixes sizes :: "nat set" ("\<K>")
  assumes block_sizes: "bl \<in># \<B> \<Longrightarrow> card bl \<in> \<K>"
  assumes positive_ints: "x \<in> \<K> \<Longrightarrow> x > 0"
begin

lemma sys_block_size_subset: "sys_block_sizes \<subseteq> \<K>"
  using block_sizes sys_block_sizes_obtain_bl by blast

end

subsubsection\<open>Uniform Block Design\<close>
text \<open>The typical uniform block design is defined below\<close>
locale block_design = proper_design +
  fixes u_block_size :: nat ("\<k>")
  assumes uniform [simp]: "bl \<in># \<B> \<Longrightarrow> card bl = \<k>"
begin

lemma k_non_zero: "\<k> \<ge> 1"
proof -
  obtain bl where bl_in: "bl \<in># \<B>"
    using design_blocks_nempty by auto
  then have "card bl \<ge> 1" using block_size_gt_0
    by (metis less_not_refl less_one not_le_imp_less)
  thus ?thesis by (simp add: bl_in)
qed

lemma uniform_alt_def_all: "\<forall> bl \<in># \<B> .card bl = \<k>"
  using uniform by auto

lemma uniform_unfold_point_set: "bl \<in># \<B> \<Longrightarrow> card {p \<in> \<V>. p \<in> bl} = \<k>"
  using uniform wellformed by (simp add: Collect_conj_eq inf.absorb_iff2)

lemma uniform_unfold_point_set_mset: "bl \<in># \<B> \<Longrightarrow> size {#p \<in># mset_set \<V>. p \<in> bl #} = \<k>"
  using uniform_unfold_point_set by (simp add: finite_sets)

lemma sys_block_sizes_uniform [simp]:  "sys_block_sizes  = {\<k>}"
proof -
  have "sys_block_sizes = {bs . \<exists> bl . bs = card bl \<and> bl\<in># \<B>}" by (simp add: sys_block_sizes_def)
  then have "sys_block_sizes  = {bs . bs = \<k>}" using uniform uniform_unfold_point_set
      b_positive block_set_nempty_imp_block_ex
    by (smt (verit, best) Collect_cong design_blocks_nempty)
  thus ?thesis by auto
qed

lemma sys_block_sizes_uniform_single: "is_singleton (sys_block_sizes)"
  by simp

lemma uniform_size_incomp: "\<k> \<le> \<v> - 1 \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  using uniform k_non_zero
  by (metis block_size_lt_v diff_diff_cancel diff_is_0_eq' less_numeral_extra(1) nat_less_le)

lemma uniform_complement_block_size:
  assumes "bl \<in># \<B>\<^sup>C"
  shows "card bl = \<v> - \<k>"
proof -
  obtain bl' where bl_assm: "bl = bl'\<^sup>c \<and> bl' \<in># \<B>"
    using wellformed assms by (auto simp add: complement_blocks_def)
  then have "int (card bl') = \<k>" by simp
  thus ?thesis using bl_assm block_complement_size wellformed
    by (simp add: block_size_lt_order of_nat_diff)
qed

lemma uniform_complement[intro]:
  assumes "\<k> \<le> \<v> - 1"
  shows "block_design \<V> \<B>\<^sup>C (\<v> - \<k>)"
proof -
  interpret des: proper_design \<V> "\<B>\<^sup>C"
    using  uniform_size_incomp assms complement_proper_design by auto
  show ?thesis using assms uniform_complement_block_size by (unfold_locales) (simp)
qed

lemma block_size_lt_v: "\<k> \<le> \<v>"
  using v_non_zero block_size_lt_v design_blocks_nempty uniform by auto

end

lemma (in proper_design) block_designI[intro]: "(\<And> bl . bl \<in># \<B> \<Longrightarrow> card bl = k)
  \<Longrightarrow> block_design \<V> \<B> k"
  by (unfold_locales) (auto)

context block_design
begin

lemma block_design_multiple: "n > 0 \<Longrightarrow> block_design \<V> (multiple_blocks n) \<k>"
  using elem_in_repeat_in_original multiple_proper_design proper_design.block_designI
  by (metis uniform_alt_def_all)

end
text \<open>A uniform block design is clearly a type of $K$\_block\_design with a singleton $K$ set\<close>
sublocale block_design \<subseteq> K_block_design \<V> \<B> "{\<k>}"
  using k_non_zero uniform by unfold_locales simp_all

subsubsection \<open>Incomplete Designs\<close>
text \<open>An incomplete design is a design where $k < v$, i.e. no block is equal to the point set\<close>
locale incomplete_design = block_design +
  assumes incomplete: "\<k> < \<v>"

begin

lemma incomplete_imp_incomp_block: "bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  using incomplete uniform uniform_size_incomp by fastforce

lemma incomplete_imp_proper_subset: "bl \<in># \<B> \<Longrightarrow> bl \<subset> \<V>"
  using incomplete_block_proper_subset incomplete_imp_incomp_block by auto
end

lemma (in block_design) incomplete_designI[intro]: "\<k> < \<v> \<Longrightarrow> incomplete_design \<V> \<B> \<k>"
  by unfold_locales auto

context incomplete_design
begin

lemma multiple_incomplete: "n > 0 \<Longrightarrow> incomplete_design \<V> (multiple_blocks n) \<k>"
  using block_design_multiple incomplete by (simp add: block_design.incomplete_designI)

lemma complement_incomplete: "incomplete_design \<V> (\<B>\<^sup>C) (\<v> - \<k>)"
proof -
  have "\<v> - \<k> < \<v>" using v_non_zero k_non_zero by linarith
  thus ?thesis using uniform_complement incomplete incomplete_designI
    by (simp add: block_design.incomplete_designI)
qed

end

subsection \<open>Balanced Designs\<close>
text \<open>t-wise balance is a design with the property that all point subsets of size $t$ occur in
$\lambda_t$ blocks\<close>

locale t_wise_balance = proper_design +
  fixes grouping :: nat ("\<t>") and index :: nat ("\<Lambda>\<^sub>t")
  assumes t_non_zero: "\<t> \<ge> 1"
  assumes t_lt_order: "\<t> \<le> \<v>"
  assumes balanced [simp]: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = \<Lambda>\<^sub>t"
begin

lemma t_non_zero_suc: "\<t> \<ge> Suc 0"
  using t_non_zero by auto

lemma balanced_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps = \<Lambda>\<^sub>t"
  using balanced by auto

end

lemma (in proper_design) t_wise_balanceI[intro]: "\<t> \<le> \<v> \<Longrightarrow> \<t> \<ge> 1 \<Longrightarrow>
  (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t>  \<Longrightarrow> \<B> index ps = \<Lambda>\<^sub>t) \<Longrightarrow> t_wise_balance \<V> \<B> \<t> \<Lambda>\<^sub>t"
  by (unfold_locales) auto

context t_wise_balance
begin

lemma obtain_t_subset_points:
  obtains T where "T \<subseteq> \<V>" "card T = \<t>" "finite T"
  using obtain_subset_with_card_n design_points_nempty t_lt_order t_non_zero finite_sets by auto

lemma multiple_t_wise_balance_index [simp]:
  assumes "ps \<subseteq> \<V>"
  assumes "card ps = \<t>"
  shows "(multiple_blocks n) index ps = \<Lambda>\<^sub>t * n"
  using multiple_point_index balanced assms by fastforce

lemma multiple_t_wise_balance:
  assumes "n > 0"
  shows "t_wise_balance \<V> (multiple_blocks n) \<t> (\<Lambda>\<^sub>t * n)"
proof -
  interpret des: proper_design \<V> "(multiple_blocks n)" by (simp add: assms multiple_proper_design)
  show ?thesis using t_non_zero t_lt_order multiple_t_wise_balance_index
    by (unfold_locales) (simp_all)
qed

lemma twise_set_pair_index: "ps \<subseteq> \<V> \<Longrightarrow> ps2 \<subseteq> \<V> \<Longrightarrow> ps \<noteq> ps2 \<Longrightarrow> card ps = \<t> \<Longrightarrow> card ps2 = \<t>
  \<Longrightarrow> \<B> index ps = \<B> index ps2"
  using balanced by simp

lemma t_wise_balance_alt: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = l2
  \<Longrightarrow> (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = l2)"
  using twise_set_pair_index by blast

lemma index_1_imp_mult_1 [simp]:
  assumes "\<Lambda>\<^sub>t = 1"
  assumes "bl \<in># \<B>"
  assumes "card bl \<ge> \<t>"
  shows "multiplicity bl = 1"
proof (rule ccontr)
  assume "\<not> (multiplicity bl = 1)"
  then have not: "multiplicity bl \<noteq> 1" by simp
  have "multiplicity bl \<noteq> 0" using assms by simp
  then have m: "multiplicity bl \<ge> 2" using not by linarith
  obtain ps where ps: "ps \<subseteq> bl \<and> card ps = \<t>"
    using assms obtain_t_subset_points
    by (metis obtain_subset_with_card_n)
  then have "\<B> index ps \<ge> 2"
    using m points_index_count_min ps by blast
  then show False using balanced ps antisym_conv2 not_numeral_less_zero numeral_le_one_iff
      points_index_ps_nin semiring_norm(69) zero_neq_numeral
    by (metis assms(1))
qed

end

subsubsection \<open>Sub-types of t-wise balance\<close>

text \<open>Pairwise balance is when $t = 2$. These are commonly of interest\<close>
locale pairwise_balance = t_wise_balance \<V> \<B> 2 \<Lambda>
  for point_set ("\<V>") and block_collection ("\<B>") and index ("\<Lambda>")

text \<open>We can combine the balance properties with $K$\_block design to define tBD's
(t-wise balanced designs), and PBD's (pairwise balanced designs)\<close>

locale tBD = t_wise_balance + K_block_design +
  assumes block_size_gt_t: "k \<in> \<K> \<Longrightarrow> k \<ge> \<t>"

locale \<Lambda>_PBD = pairwise_balance + K_block_design +
  assumes block_size_gt_t: "k \<in> \<K> \<Longrightarrow> k \<ge> 2"

sublocale \<Lambda>_PBD \<subseteq> tBD \<V> \<B> 2 \<Lambda> \<K>
  using t_lt_order block_size_gt_t by (unfold_locales) (simp_all)

locale PBD = \<Lambda>_PBD \<V> \<B> 1 \<K> for point_set ("\<V>") and block_collection ("\<B>") and sizes ("\<K>")
begin
lemma multiplicity_is_1:
  assumes "bl \<in># \<B>"
  shows "multiplicity bl = 1"
  using block_size_gt_t index_1_imp_mult_1 by (simp add: assms block_sizes)

end

sublocale PBD \<subseteq> simple_design
  using multiplicity_is_1 by (unfold_locales)

text \<open>PBD's are often only used in the case where $k$ is uniform, defined here.\<close>
locale k_\<Lambda>_PBD = pairwise_balance + block_design +
  assumes block_size_t: "2 \<le> \<k>"

sublocale k_\<Lambda>_PBD \<subseteq> \<Lambda>_PBD \<V> \<B> \<Lambda> "{\<k>}"
  using k_non_zero uniform block_size_t by(unfold_locales) (simp_all)

locale k_PBD = k_\<Lambda>_PBD \<V> \<B> 1 \<k> for point_set ("\<V>") and block_collection ("\<B>") and u_block_size ("\<k>")

sublocale k_PBD \<subseteq> PBD \<V> \<B> "{\<k>}"
  using  block_size_t by (unfold_locales, simp_all)

subsubsection \<open>Covering and Packing Designs\<close>
text \<open>Covering and packing designs involve a looser balance restriction. Upper/lower bounds
are placed on the points index, instead of a strict equality\<close>

text \<open>A t-covering design is a relaxed version of a tBD, where, for all point subsets of size t,
a lower bound is put on the points index\<close>
locale t_covering_design = block_design +
  fixes grouping :: nat ("\<t>")
  fixes min_index :: nat ("\<Lambda>\<^sub>t")
  assumes covering: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t"
  assumes block_size_t: "\<t> \<le> \<k>"
  assumes t_non_zero: "\<t> \<ge> 1"
begin

lemma covering_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t"
  using covering by auto

end

lemma (in block_design) t_covering_designI [intro]: "t \<le> \<k> \<Longrightarrow> t \<ge> 1 \<Longrightarrow>
  (\<And> ps. ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t) \<Longrightarrow> t_covering_design \<V> \<B> \<k> t \<Lambda>\<^sub>t"
  by (unfold_locales) simp_all

text \<open>A t-packing design is a relaxed version of a tBD, where, for all point subsets of size t,
an upper bound is put on the points index\<close>
locale t_packing_design = block_design +
  fixes grouping :: nat ("\<t>")
  fixes min_index :: nat ("\<Lambda>\<^sub>t")
  assumes packing: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t"
  assumes block_size_t: "\<t> \<le> \<k>"
  assumes t_non_zero: "\<t> \<ge> 1"
begin

lemma packing_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t"
  using packing by auto

end

lemma (in block_design) t_packing_designI [intro]: "t \<le> \<k> \<Longrightarrow> t \<ge> 1 \<Longrightarrow>
  (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t) \<Longrightarrow> t_packing_design \<V> \<B> \<k> t \<Lambda>\<^sub>t"
  by (unfold_locales) simp_all

lemma packing_covering_imp_balance:
  assumes "t_packing_design V B k t \<Lambda>\<^sub>t"
  assumes "t_covering_design V B k t \<Lambda>\<^sub>t"
  shows "t_wise_balance V B t \<Lambda>\<^sub>t"
proof -
  from assms interpret des: proper_design V B
    using block_design.axioms(1) t_covering_design.axioms(1) by blast
  show ?thesis
  proof (unfold_locales)
    show "1 \<le> t" using assms t_packing_design.t_non_zero by auto
    show "t \<le> des.\<v>" using block_design.block_size_lt_v t_packing_design.axioms(1)
      by (metis assms(1) dual_order.trans t_packing_design.block_size_t)
    show "\<And>ps. ps \<subseteq> V \<Longrightarrow> card ps = t \<Longrightarrow> B index ps = \<Lambda>\<^sub>t"
      using t_packing_design.packing t_covering_design.covering by (metis assms dual_order.antisym)
  qed
qed

subsection \<open>Constant Replication Design\<close>
text \<open>When the replication number for all points in a design is constant, it is the
design replication number.\<close>
locale constant_rep_design = proper_design +
  fixes design_rep_number :: nat ("\<r>")
  assumes rep_number [simp]: "x \<in> \<V> \<Longrightarrow>  \<B> rep x = \<r>"

begin

lemma rep_number_alt_def_all: "\<forall> x \<in> \<V>. \<B> rep x = \<r>"
  by (simp)

lemma rep_number_unfold_set: "x \<in> \<V> \<Longrightarrow> size {#bl \<in># \<B> . x \<in> bl#} = \<r>"
  using rep_number by (simp add: point_replication_number_def)

lemma rep_numbers_constant [simp]: "replication_numbers  = {\<r>}"
  unfolding replication_numbers_def using rep_number design_points_nempty Collect_cong finite.cases
    finite_sets insertCI singleton_conv
  by (smt (verit, ccfv_threshold) fst_conv snd_conv)

lemma replication_number_single: "is_singleton (replication_numbers)"
  using is_singleton_the_elem by simp

lemma constant_rep_point_pair: "x1 \<in> \<V> \<Longrightarrow> x2 \<in> \<V> \<Longrightarrow> x1 \<noteq> x2 \<Longrightarrow> \<B> rep x1 = \<B> rep x2"
  using rep_number by auto

lemma constant_rep_alt: "x1 \<in> \<V> \<Longrightarrow> \<B> rep x1 = r2 \<Longrightarrow> (\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = r2)"
  by (simp)

lemma constant_rep_point_not_0:
  assumes "x \<in> \<V>"
  shows "\<B> rep x \<noteq> 0"
proof (rule ccontr)
  assume "\<not> \<B> rep x \<noteq> 0"
  then have "\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = 0" using rep_number assms by auto
  then have "\<And> x . x \<in> \<V> \<Longrightarrow>  size {#bl \<in># \<B> . x \<in> bl#} = 0"
    by (simp add: point_replication_number_def)
  then show False using design_blocks_nempty wf_design wf_design_iff wf_invalid_point
    by (metis ex_in_conv filter_mset_empty_conv multiset_nonemptyE size_eq_0_iff_empty)
qed

lemma rep_not_zero: "\<r> \<noteq> 0"
  using rep_number constant_rep_point_not_0 design_points_nempty by auto

lemma r_gzero: "\<r> > 0"
  using rep_not_zero by auto

lemma r_lt_eq_b: "\<r> \<le> \<b>"
  using rep_number max_point_rep
  by (metis all_not_in_conv design_points_nempty)

lemma complement_rep_number:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "constant_rep_design \<V> \<B>\<^sup>C (\<b> - \<r>)"
proof -
  interpret d: proper_design \<V> "(\<B>\<^sup>C)" using complement_proper_design
    by (simp add: assms)
  show ?thesis using complement_rep_number rep_number by (unfold_locales) simp
qed

lemma multiple_rep_number:
  assumes "n > 0"
  shows "constant_rep_design \<V> (multiple_blocks n) (\<r> * n)"
proof -
  interpret d: proper_design \<V> "(multiple_blocks n)" using multiple_proper_design
    by (simp add: assms)
  show ?thesis using multiple_point_rep_num by (unfold_locales) (simp_all)
qed
end

lemma (in proper_design) constant_rep_designI [intro]: "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = \<r>)
    \<Longrightarrow> constant_rep_design \<V> \<B> \<r>"
  by unfold_locales auto

subsection \<open>T-designs\<close>
text \<open>All the before mentioned designs build up to the concept of a t-design, which has uniform
block size and is t-wise balanced. We limit $t$ to be less than $k$, so the balance condition has
relevance\<close>
locale t_design = incomplete_design + t_wise_balance +
  assumes block_size_t: "\<t> \<le> \<k>"
begin

lemma point_indices_balanced: "point_indices \<t> = {\<Lambda>\<^sub>t}"
proof -
  have "point_indices \<t> = {i . \<exists> ps . i = \<B> index ps \<and> card ps = \<t> \<and> ps \<subseteq> \<V>}"
    by (simp add: point_indices_def)
  then have "point_indices  \<t> = {i . i = \<Lambda>\<^sub>t}" using balanced Collect_cong obtain_t_subset_points
     by (smt (verit, best))
  thus ?thesis by auto
qed

lemma point_indices_singleton: "is_singleton (point_indices \<t>)"
  using point_indices_balanced is_singleton_the_elem by simp

end

lemma t_designI [intro]:
  assumes "incomplete_design V B k"
  assumes "t_wise_balance V B t \<Lambda>\<^sub>t"
  assumes "t \<le> k"
  shows "t_design V B k t \<Lambda>\<^sub>t"
  by (simp add: assms(1) assms(2) assms(3) t_design.intro t_design_axioms.intro)

sublocale t_design \<subseteq> t_covering_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t
  using t_non_zero by (unfold_locales) (auto simp add: block_size_t)

sublocale t_design \<subseteq> t_packing_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t
  using t_non_zero by (unfold_locales) (auto simp add: block_size_t)

lemma t_design_pack_cov [intro]:
  assumes "k < card V"
  assumes "t_covering_design V B k t \<Lambda>\<^sub>t"
  assumes "t_packing_design V B k t \<Lambda>\<^sub>t"
  shows "t_design V B k t \<Lambda>\<^sub>t"
proof -
  from assms interpret id: incomplete_design V B k
    using block_design.incomplete_designI t_packing_design.axioms(1)
    by blast
  from assms interpret balance: t_wise_balance V B t \<Lambda>\<^sub>t
    using packing_covering_imp_balance by blast
  show ?thesis using assms(3)
    by (unfold_locales) (simp_all add: t_packing_design.block_size_t)
qed

sublocale t_design \<subseteq> tBD \<V> \<B> \<t> \<Lambda>\<^sub>t "{\<k>}"
  using uniform k_non_zero block_size_t by (unfold_locales) simp_all

context t_design
begin

lemma multiple_t_design: "n > 0 \<Longrightarrow> t_design \<V> (multiple_blocks n) \<k> \<t> (\<Lambda>\<^sub>t * n)"
  using multiple_t_wise_balance multiple_incomplete block_size_t by (simp add: t_designI)

lemma t_design_min_v: "\<v> > 1"
  using k_non_zero incomplete by simp

end

subsection \<open>Steiner Systems\<close>

text \<open>Steiner systems are a special type of t-design where $\Lambda_t = 1$\<close>
locale steiner_system = t_design \<V> \<B> \<k> \<t> 1
  for point_set ("\<V>") and block_collection ("\<B>") and u_block_size ("\<k>") and grouping ("\<t>")

begin

lemma block_multiplicity [simp]:
  assumes "bl \<in># \<B>"
  shows "multiplicity bl = 1"
  by (simp add: assms block_size_t)

end

sublocale steiner_system \<subseteq> simple_design
  by unfold_locales (simp)

lemma (in t_design) steiner_systemI[intro]: "\<Lambda>\<^sub>t = 1 \<Longrightarrow> steiner_system \<V> \<B> \<k> \<t>"
  using t_non_zero t_lt_order block_size_t
  by unfold_locales auto

subsection \<open>Combining block designs\<close>
text \<open>We define some closure properties for various block designs under the combine operator.
This is done using locales to reason on multiple instances of the same type of design, building
on what was presented in the design operations theory\<close>

locale two_t_wise_eq_points = two_designs_proper \<V> \<B> \<V> \<B>' + des1: t_wise_balance \<V> \<B> \<t> \<Lambda>\<^sub>t +
  des2: t_wise_balance \<V> \<B>' \<t> \<Lambda>\<^sub>t' for \<V> \<B> \<t> \<Lambda>\<^sub>t \<B>' \<Lambda>\<^sub>t'
begin

lemma combine_t_wise_balance_index: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B>\<^sup>+ index ps = (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using des1.balanced des2.balanced by (simp add: combine_points_index)

lemma combine_t_wise_balance: "t_wise_balance \<V>\<^sup>+ \<B>\<^sup>+ \<t> (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
proof (unfold_locales, simp add: des1.t_non_zero_suc)
  have "card \<V>\<^sup>+  \<ge> card \<V>" by simp
  then show "\<t> \<le> card (\<V>\<^sup>+)" using des1.t_lt_order by linarith
  show "\<And>ps. ps \<subseteq> \<V>\<^sup>+ \<Longrightarrow> card ps = \<t> \<Longrightarrow> (\<B>\<^sup>+ index ps) = \<Lambda>\<^sub>t + \<Lambda>\<^sub>t'"
    using combine_t_wise_balance_index by blast
qed

sublocale combine_t_wise_des: t_wise_balance "\<V>\<^sup>+" "\<B>\<^sup>+" "\<t>" "(\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using combine_t_wise_balance by auto

end

locale two_k_block_designs = two_designs_proper \<V> \<B> \<V>' \<B>' + des1: block_design \<V> \<B> \<k> +
  des2: block_design \<V>' \<B>' \<k> for \<V> \<B> \<k> \<V>' \<B>'
begin

lemma block_design_combine: "block_design \<V>\<^sup>+ \<B>\<^sup>+ \<k>"
  using des1.uniform des2.uniform by (unfold_locales) (auto)

sublocale combine_block_des: block_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>"
  using block_design_combine by simp

end

locale two_rep_designs_eq_points = two_designs_proper \<V> \<B> \<V> \<B>' + des1: constant_rep_design \<V> \<B> \<r> +
  des2: constant_rep_design \<V> \<B>' \<r>' for \<V> \<B> \<r> \<B>' \<r>'
begin

lemma combine_rep_number: "constant_rep_design \<V>\<^sup>+ \<B>\<^sup>+ (\<r> + \<r>')"
  using combine_rep_number des1.rep_number des2.rep_number by (unfold_locales) (simp)

sublocale combine_const_rep: constant_rep_design "\<V>\<^sup>+" "\<B>\<^sup>+" "(\<r> + \<r>')"
  using combine_rep_number by simp

end

locale two_incomplete_designs = two_k_block_designs \<V> \<B> \<k> \<V>' \<B>' + des1: incomplete_design \<V> \<B> \<k> +
  des2: incomplete_design \<V>' \<B>' \<k> for \<V> \<B> \<k> \<V>' \<B>'
begin

lemma combine_is_incomplete: "incomplete_design \<V>\<^sup>+ \<B>\<^sup>+ \<k>"
  using combine_order des1.incomplete des2.incomplete by (unfold_locales) (simp)

sublocale combine_incomplete: incomplete_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>"
  using combine_is_incomplete by simp
end

locale two_t_designs_eq_points = two_incomplete_designs \<V> \<B> \<k> \<V> \<B>'
  + two_t_wise_eq_points \<V> \<B> \<t> \<Lambda>\<^sub>t \<B>' \<Lambda>\<^sub>t' + des1: t_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t +
  des2: t_design \<V> \<B>' \<k> \<t> \<Lambda>\<^sub>t' for \<V> \<B> \<k> \<B>' \<t> \<Lambda>\<^sub>t \<Lambda>\<^sub>t'
begin

lemma combine_is_t_des: "t_design \<V>\<^sup>+ \<B>\<^sup>+ \<k> \<t> (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using des1.block_size_t des2.block_size_t by (unfold_locales)

sublocale combine_t_des: t_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>" "\<t>" "(\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using combine_is_t_des by blast

end
end


theory E2_10
  imports Main
begin

datatype tree0 = Leaf | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Leaf = 1" |
  "nodes (Node l r) = 1 + (nodes l) + (nodes r)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node t t)"

lemma "nodes (explode n t) = (nodes t) * (2 ^ n) + 2 ^ n - 1"
  apply(induction n arbitrary: t)
  apply(simp_all add: algebra_simps)
  done

end


theory week03B_demo_automation imports Main begin

definition
  xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor A B \<equiv> (A \<and> \<not>B) \<or> (\<not>A \<and> B)"

lemma xorI [intro!]:
  "\<lbrakk> \<lbrakk>A; B\<rbrakk> \<Longrightarrow> False; \<not>B \<Longrightarrow> A \<rbrakk> \<Longrightarrow> xor A B"
  apply (unfold xor_def)
  apply blast
  done

lemma xorE:
  "\<lbrakk> xor A B; \<lbrakk>A; \<not>B\<rbrakk> \<Longrightarrow> R; \<lbrakk>\<not>A; B\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply (unfold xor_def)
  apply blast
  done

lemma "xor A A = False" by (blast elim!: xorE)

declare xorE [elim!]

lemma "xor A B = xor B A" by blast

end


theory List_Demo
imports Main
begin

datatype 'a list = Nil | Cons "'a" "'a list"

term "Nil"

declare [[names_short]]

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

lemma app_Nil2[simp]: "app xs Nil = xs"
apply (induction xs)
apply auto
done

lemma app_assoc[simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply (induction xs)
apply auto
done

lemma rev_app[simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
apply (induction xs)
apply auto
done

theorem rev_rev[simp]: "rev (rev xs) = xs"
apply (induction xs)
apply auto
done

end