(*  Title:      HOL/Algebra/Ideal.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory Ideal
imports Ring AbelCoset
begin

section {* Ideals *}

subsection {* Definitions *}

subsubsection {* General definition *}

locale ideal = additive_subgroup I R + ring R for I and R (structure) +
  assumes I_l_closed: "\<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> a \<in> I"
    and I_r_closed: "\<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> a \<otimes> x \<in> I"

sublocale ideal \<subseteq> abelian_subgroup I R
  apply (intro abelian_subgroupI3 abelian_group.intro)
    apply (rule ideal.axioms, rule ideal_axioms)
   apply (rule abelian_group.axioms, rule ring.axioms, rule ideal.axioms, rule ideal_axioms)
  apply (rule abelian_group.axioms, rule ring.axioms, rule ideal.axioms, rule ideal_axioms)
  done

lemma (in ideal) is_ideal: "ideal I R"
  by (rule ideal_axioms)

lemma idealI:
  fixes R (structure)
  assumes "ring R"
  assumes a_subgroup: "subgroup I \<lparr>carrier = carrier R, mult = add R, one = zero R\<rparr>"
    and I_l_closed: "\<And>a x. \<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> a \<in> I"
    and I_r_closed: "\<And>a x. \<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> a \<otimes> x \<in> I"
  shows "ideal I R"
proof -
  interpret ring R by fact
  show ?thesis  apply (intro ideal.intro ideal_axioms.intro additive_subgroupI)
     apply (rule a_subgroup)
    apply (rule is_ring)
   apply (erule (1) I_l_closed)
  apply (erule (1) I_r_closed)
  done
qed

subsubsection (in ring) {* Ideals Generated by a Subset of @{term "carrier R"} *}

definition genideal :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set"  ("Idl\<index> _" [80] 79)
  where "genideal R S = Inter {I. ideal I R \<and> S \<subseteq> I}"

subsubsection {* Principal Ideals *}

locale principalideal = ideal +
  assumes generate: "\<exists>i \<in> carrier R. I = Idl {i}"

lemma (in principalideal) is_principalideal: "principalideal I R"
  by (rule principalideal_axioms)

lemma principalidealI:
  fixes R (structure)
  assumes "ideal I R"
    and generate: "\<exists>i \<in> carrier R. I = Idl {i}"
  shows "principalideal I R"
proof -
  interpret ideal I R by fact
  show ?thesis
    by (intro principalideal.intro principalideal_axioms.intro)
      (rule is_ideal, rule generate)
qed

subsubsection {* Maximal Ideals *}

locale maximalideal = ideal +
  assumes I_notcarr: "carrier R \<noteq> I"
    and I_maximal: "\<lbrakk>ideal J R; I \<subseteq> J; J \<subseteq> carrier R\<rbrakk> \<Longrightarrow> J = I \<or> J = carrier R"

lemma (in maximalideal) is_maximalideal: "maximalideal I R"
  by (rule maximalideal_axioms)

lemma maximalidealI:
  fixes R
  assumes "ideal I R"
    and I_notcarr: "carrier R \<noteq> I"
    and I_maximal: "\<And>J. \<lbrakk>ideal J R; I \<subseteq> J; J \<subseteq> carrier R\<rbrakk> \<Longrightarrow> J = I \<or> J = carrier R"
  shows "maximalideal I R"
proof -
  interpret ideal I R by fact
  show ?thesis
    by (intro maximalideal.intro maximalideal_axioms.intro)
      (rule is_ideal, rule I_notcarr, rule I_maximal)
qed

subsubsection {* Prime Ideals *}

locale primeideal = ideal + cring +
  assumes I_notcarr: "carrier R \<noteq> I"
    and I_prime: "\<lbrakk>a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> I\<rbrakk> \<Longrightarrow> a \<in> I \<or> b \<in> I"

lemma (in primeideal) is_primeideal: "primeideal I R"
  by (rule primeideal_axioms)

lemma primeidealI:
  fixes R (structure)
  assumes "ideal I R"
    and "cring R"
    and I_notcarr: "carrier R \<noteq> I"
    and I_prime: "\<And>a b. \<lbrakk>a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> I\<rbrakk> \<Longrightarrow> a \<in> I \<or> b \<in> I"
  shows "primeideal I R"
proof -
  interpret ideal I R by fact
  interpret cring R by fact
  show ?thesis
    by (intro primeideal.intro primeideal_axioms.intro)
      (rule is_ideal, rule is_cring, rule I_notcarr, rule I_prime)
qed

lemma primeidealI2:
  fixes R (structure)
  assumes "additive_subgroup I R"
    and "cring R"
    and I_l_closed: "\<And>a x. \<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> a \<in> I"
    and I_r_closed: "\<And>a x. \<lbrakk>a \<in> I; x \<in> carrier R\<rbrakk> \<Longrightarrow> a \<otimes> x \<in> I"
    and I_notcarr: "carrier R \<noteq> I"
    and I_prime: "\<And>a b. \<lbrakk>a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> I\<rbrakk> \<Longrightarrow> a \<in> I \<or> b \<in> I"
  shows "primeideal I R"
proof -
  interpret additive_subgroup I R by fact
  interpret cring R by fact
  show ?thesis apply (intro_locales)
    apply (intro ideal_axioms.intro)
    apply (erule (1) I_l_closed)
    apply (erule (1) I_r_closed)
    apply (intro primeideal_axioms.intro)
    apply (rule I_notcarr)
    apply (erule (2) I_prime)
    done
qed

subsection {* Special Ideals *}

lemma (in ring) zeroideal: "ideal {\<zero>} R"
  apply (intro idealI subgroup.intro)
        apply (rule is_ring)
       apply simp+
    apply (fold a_inv_def, simp)
   apply simp+
  done

lemma (in ring) oneideal: "ideal (carrier R) R"
  by (rule idealI) (auto intro: is_ring add.subgroupI)

lemma (in "domain") zeroprimeideal: "primeideal {\<zero>} R"
  apply (intro primeidealI)
     apply (rule zeroideal)
    apply (rule domain.axioms, rule domain_axioms)
   defer 1
   apply (simp add: integral)
proof (rule ccontr, simp)
  assume "carrier R = {\<zero>}"
  then have "\<one> = \<zero>" by (rule one_zeroI)
  with one_not_zero show False by simp
qed

subsection {* General Ideal Properies *}

lemma (in ideal) one_imp_carrier:
  assumes I_one_closed: "\<one> \<in> I"
  shows "I = carrier R"
  apply (rule)
  apply (rule)
  apply (rule a_Hcarr, simp)
proof
  fix x
  assume xcarr: "x \<in> carrier R"
  with I_one_closed have "x \<otimes> \<one> \<in> I" by (intro I_l_closed)
  with xcarr show "x \<in> I" by simp
qed

lemma (in ideal) Icarr:
  assumes iI: "i \<in> I"
  shows "i \<in> carrier R"
  using iI by (rule a_Hcarr)

subsection {* Intersection of Ideals *}

text {* \paragraph{Intersection of two ideals} The intersection of any
  two ideals is again an ideal in @{term R} *}
lemma (in ring) i_intersect:
  assumes "ideal I R"
  assumes "ideal J R"
  shows "ideal (I \<inter> J) R"
proof -
  interpret ideal I R by fact
  interpret ideal J R by fact
  show ?thesis
    apply (intro idealI subgroup.intro)
          apply (rule is_ring)
         apply (force simp add: a_subset)
        apply (simp add: a_inv_def[symmetric])
       apply simp
      apply (simp add: a_inv_def[symmetric])
     apply (clarsimp, rule)
      apply (fast intro: ideal.I_l_closed ideal.intro assms)+
    apply (clarsimp, rule)
     apply (fast intro: ideal.I_r_closed ideal.intro assms)+
    done
qed

text {* The intersection of any Number of Ideals is again
        an Ideal in @{term R} *}
lemma (in ring) i_Intersect:
  assumes Sideals: "\<And>I. I \<in> S \<Longrightarrow> ideal I R"
    and notempty: "S \<noteq> {}"
  shows "ideal (Inter S) R"
  apply (unfold_locales)
  apply (simp_all add: Inter_eq)
        apply rule unfolding mem_Collect_eq defer 1
        apply rule defer 1
        apply rule defer 1
        apply (fold a_inv_def, rule) defer 1
        apply rule defer 1
        apply rule defer 1
proof -
  fix x y
  assume "\<forall>I\<in>S. x \<in> I"
  then have xI: "\<And>I. I \<in> S \<Longrightarrow> x \<in> I" by simp
  assume "\<forall>I\<in>S. y \<in> I"
  then have yI: "\<And>I. I \<in> S \<Longrightarrow> y \<in> I" by simp

  fix J
  assume JS: "J \<in> S"
  interpret ideal J R by (rule Sideals[OF JS])
  from xI[OF JS] and yI[OF JS] show "x \<oplus> y \<in> J" by (rule a_closed)
next
  fix J
  assume JS: "J \<in> S"
  interpret ideal J R by (rule Sideals[OF JS])
  show "\<zero> \<in> J" by simp
next
  fix x
  assume "\<forall>I\<in>S. x \<in> I"
  then have xI: "\<And>I. I \<in> S \<Longrightarrow> x \<in> I" by simp

  fix J
  assume JS: "J \<in> S"
  interpret ideal J R by (rule Sideals[OF JS])

  from xI[OF JS] show "\<ominus> x \<in> J" by (rule a_inv_closed)
next
  fix x y
  assume "\<forall>I\<in>S. x \<in> I"
  then have xI: "\<And>I. I \<in> S \<Longrightarrow> x \<in> I" by simp
  assume ycarr: "y \<in> carrier R"

  fix J
  assume JS: "J \<in> S"
  interpret ideal J R by (rule Sideals[OF JS])

  from xI[OF JS] and ycarr show "y \<otimes> x \<in> J" by (rule I_l_closed)
next
  fix x y
  assume "\<forall>I\<in>S. x \<in> I"
  then have xI: "\<And>I. I \<in> S \<Longrightarrow> x \<in> I" by simp
  assume ycarr: "y \<in> carrier R"

  fix J
  assume JS: "J \<in> S"
  interpret ideal J R by (rule Sideals[OF JS])

  from xI[OF JS] and ycarr show "x \<otimes> y \<in> J" by (rule I_r_closed)
next
  fix x
  assume "\<forall>I\<in>S. x \<in> I"
  then have xI: "\<And>I. I \<in> S \<Longrightarrow> x \<in> I" by simp

  from notempty have "\<exists>I0. I0 \<in> S" by blast
  then obtain I0 where I0S: "I0 \<in> S" by auto

  interpret ideal I0 R by (rule Sideals[OF I0S])

  from xI[OF I0S] have "x \<in> I0" .
  with a_subset show "x \<in> carrier R" by fast
next

qed

subsection {* Addition of Ideals *}

lemma (in ring) add_ideals:
  assumes idealI: "ideal I R"
      and idealJ: "ideal J R"
  shows "ideal (I <+> J) R"
  apply (rule ideal.intro)
    apply (rule add_additive_subgroups)
     apply (intro ideal.axioms[OF idealI])
    apply (intro ideal.axioms[OF idealJ])
   apply (rule is_ring)
  apply (rule ideal_axioms.intro)
   apply (simp add: set_add_defs, clarsimp) defer 1
   apply (simp add: set_add_defs, clarsimp) defer 1
proof -
  fix x i j
  assume xcarr: "x \<in> carrier R"
    and iI: "i \<in> I"
    and jJ: "j \<in> J"
  from xcarr ideal.Icarr[OF idealI iI] ideal.Icarr[OF idealJ jJ]
  have c: "(i \<oplus> j) \<otimes> x = (i \<otimes> x) \<oplus> (j \<otimes> x)"
    by algebra
  from xcarr and iI have a: "i \<otimes> x \<in> I"
    by (simp add: ideal.I_r_closed[OF idealI])
  from xcarr and jJ have b: "j \<otimes> x \<in> J"
    by (simp add: ideal.I_r_closed[OF idealJ])
  from a b c show "\<exists>ha\<in>I. \<exists>ka\<in>J. (i \<oplus> j) \<otimes> x = ha \<oplus> ka"
    by fast
next
  fix x i j
  assume xcarr: "x \<in> carrier R"
    and iI: "i \<in> I"
    and jJ: "j \<in> J"
  from xcarr ideal.Icarr[OF idealI iI] ideal.Icarr[OF idealJ jJ]
  have c: "x \<otimes> (i \<oplus> j) = (x \<otimes> i) \<oplus> (x \<otimes> j)" by algebra
  from xcarr and iI have a: "x \<otimes> i \<in> I"
    by (simp add: ideal.I_l_closed[OF idealI])
  from xcarr and jJ have b: "x \<otimes> j \<in> J"
    by (simp add: ideal.I_l_closed[OF idealJ])
  from a b c show "\<exists>ha\<in>I. \<exists>ka\<in>J. x \<otimes> (i \<oplus> j) = ha \<oplus> ka"
    by fast
qed

subsection (in ring) {* Ideals generated by a subset of @{term "carrier R"} *}

text {* @{term genideal} generates an ideal *}
lemma (in ring) genideal_ideal:
  assumes Scarr: "S \<subseteq> carrier R"
  shows "ideal (Idl S) R"
unfolding genideal_def
proof (rule i_Intersect, fast, simp)
  from oneideal and Scarr
  show "\<exists>I. ideal I R \<and> S \<le> I" by fast
qed

lemma (in ring) genideal_self:
  assumes "S \<subseteq> carrier R"
  shows "S \<subseteq> Idl S"
  unfolding genideal_def by fast

lemma (in ring) genideal_self':
  assumes carr: "i \<in> carrier R"
  shows "i \<in> Idl {i}"
proof -
  from carr have "{i} \<subseteq> Idl {i}" by (fast intro!: genideal_self)
  then show "i \<in> Idl {i}" by fast
qed

text {* @{term genideal} generates the minimal ideal *}
lemma (in ring) genideal_minimal:
  assumes a: "ideal I R"
    and b: "S \<subseteq> I"
  shows "Idl S \<subseteq> I"
  unfolding genideal_def by rule (elim InterD, simp add: a b)

text {* Generated ideals and subsets *}
lemma (in ring) Idl_subset_ideal:
  assumes Iideal: "ideal I R"
    and Hcarr: "H \<subseteq> carrier R"
  shows "(Idl H \<subseteq> I) = (H \<subseteq> I)"
proof
  assume a: "Idl H \<subseteq> I"
  from Hcarr have "H \<subseteq> Idl H" by (rule genideal_self)
  with a show "H \<subseteq> I" by simp
next
  fix x
  assume "H \<subseteq> I"
  with Iideal have "I \<in> {I. ideal I R \<and> H \<subseteq> I}" by fast
  then show "Idl H \<subseteq> I" unfolding genideal_def by fast
qed

lemma (in ring) subset_Idl_subset:
  assumes Icarr: "I \<subseteq> carrier R"
    and HI: "H \<subseteq> I"
  shows "Idl H \<subseteq> Idl I"
proof -
  from HI and genideal_self[OF Icarr] have HIdlI: "H \<subseteq> Idl I"
    by fast

  from Icarr have Iideal: "ideal (Idl I) R"
    by (rule genideal_ideal)
  from HI and Icarr have "H \<subseteq> carrier R"
    by fast
  with Iideal have "(H \<subseteq> Idl I) = (Idl H \<subseteq> Idl I)"
    by (rule Idl_subset_ideal[symmetric])

  with HIdlI show "Idl H \<subseteq> Idl I" by simp
qed

lemma (in ring) Idl_subset_ideal':
  assumes acarr: "a \<in> carrier R" and bcarr: "b \<in> carrier R"
  shows "(Idl {a} \<subseteq> Idl {b}) = (a \<in> Idl {b})"
  apply (subst Idl_subset_ideal[OF genideal_ideal[of "{b}"], of "{a}"])
    apply (fast intro: bcarr, fast intro: acarr)
  apply fast
  done

lemma (in ring) genideal_zero: "Idl {\<zero>} = {\<zero>}"
  apply rule
   apply (rule genideal_minimal[OF zeroideal], simp)
  apply (simp add: genideal_self')
  done

lemma (in ring) genideal_one: "Idl {\<one>} = carrier R"
proof -
  interpret ideal "Idl {\<one>}" "R" by (rule genideal_ideal) fast
  show "Idl {\<one>} = carrier R"
  apply (rule, rule a_subset)
  apply (simp add: one_imp_carrier genideal_self')
  done
qed

text {* Generation of Principal Ideals in Commutative Rings *}

definition cgenideal :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set"  ("PIdl\<index> _" [80] 79)
  where "cgenideal R a = {x \<otimes>\<^bsub>R\<^esub> a | x. x \<in> carrier R}"

text {* genhideal (?) really generates an ideal *}
lemma (in cring) cgenideal_ideal:
  assumes acarr: "a \<in> carrier R"
  shows "ideal (PIdl a) R"
  apply (unfold cgenideal_def)
  apply (rule idealI[OF is_ring])
     apply (rule subgroup.intro)
        apply simp_all
        apply (blast intro: acarr)
        apply clarsimp defer 1
        defer 1
        apply (fold a_inv_def, clarsimp) defer 1
        apply clarsimp defer 1
        apply clarsimp defer 1
proof -
  fix x y
  assume xcarr: "x \<in> carrier R"
    and ycarr: "y \<in> carrier R"
  note carr = acarr xcarr ycarr

  from carr have "x \<otimes> a \<oplus> y \<otimes> a = (x \<oplus> y) \<otimes> a"
    by (simp add: l_distr)
  with carr show "\<exists>z. x \<otimes> a \<oplus> y \<otimes> a = z \<otimes> a \<and> z \<in> carrier R"
    by fast
next
  from l_null[OF acarr, symmetric] and zero_closed
  show "\<exists>x. \<zero> = x \<otimes> a \<and> x \<in> carrier R" by fast
next
  fix x
  assume xcarr: "x \<in> carrier R"
  note carr = acarr xcarr

  from carr have "\<ominus> (x \<otimes> a) = (\<ominus> x) \<otimes> a"
    by (simp add: l_minus)
  with carr show "\<exists>z. \<ominus> (x \<otimes> a) = z \<otimes> a \<and> z \<in> carrier R"
    by fast
next
  fix x y
  assume xcarr: "x \<in> carrier R"
     and ycarr: "y \<in> carrier R"
  note carr = acarr xcarr ycarr

  from carr have "y \<otimes> a \<otimes> x = (y \<otimes> x) \<otimes> a"
    by (simp add: m_assoc) (simp add: m_comm)
  with carr show "\<exists>z. y \<otimes> a \<otimes> x = z \<otimes> a \<and> z \<in> carrier R"
    by fast
next
  fix x y
  assume xcarr: "x \<in> carrier R"
     and ycarr: "y \<in> carrier R"
  note carr = acarr xcarr ycarr

  from carr have "x \<otimes> (y \<otimes> a) = (x \<otimes> y) \<otimes> a"
    by (simp add: m_assoc)
  with carr show "\<exists>z. x \<otimes> (y \<otimes> a) = z \<otimes> a \<and> z \<in> carrier R"
    by fast
qed

lemma (in ring) cgenideal_self:
  assumes icarr: "i \<in> carrier R"
  shows "i \<in> PIdl i"
  unfolding cgenideal_def
proof simp
  from icarr have "i = \<one> \<otimes> i"
    by simp
  with icarr show "\<exists>x. i = x \<otimes> i \<and> x \<in> carrier R"
    by fast
qed

text {* @{const "cgenideal"} is minimal *}

lemma (in ring) cgenideal_minimal:
  assumes "ideal J R"
  assumes aJ: "a \<in> J"
  shows "PIdl a \<subseteq> J"
proof -
  interpret ideal J R by fact
  show ?thesis
    unfolding cgenideal_def
    apply rule
    apply clarify
    using aJ
    apply (erule I_l_closed)
    done
qed

lemma (in cring) cgenideal_eq_genideal:
  assumes icarr: "i \<in> carrier R"
  shows "PIdl i = Idl {i}"
  apply rule
   apply (intro cgenideal_minimal)
    apply (rule genideal_ideal, fast intro: icarr)
   apply (rule genideal_self', fast intro: icarr)
  apply (intro genideal_minimal)
   apply (rule cgenideal_ideal [OF icarr])
  apply (simp, rule cgenideal_self [OF icarr])
  done

lemma (in cring) cgenideal_eq_rcos: "PIdl i = carrier R #> i"
  unfolding cgenideal_def r_coset_def by fast

lemma (in cring) cgenideal_is_principalideal:
  assumes icarr: "i \<in> carrier R"
  shows "principalideal (PIdl i) R"
  apply (rule principalidealI)
  apply (rule cgenideal_ideal [OF icarr])
proof -
  from icarr have "PIdl i = Idl {i}"
    by (rule cgenideal_eq_genideal)
  with icarr show "\<exists>i'\<in>carrier R. PIdl i = Idl {i'}"
    by fast
qed

subsection {* Union of Ideals *}

lemma (in ring) union_genideal:
  assumes idealI: "ideal I R"
    and idealJ: "ideal J R"
  shows "Idl (I \<union> J) = I <+> J"
  apply rule
   apply (rule ring.genideal_minimal)
     apply (rule is_ring)
    apply (rule add_ideals[OF idealI idealJ])
   apply (rule)
   apply (simp add: set_add_defs) apply (elim disjE) defer 1 defer 1
   apply (rule) apply (simp add: set_add_defs genideal_def) apply clarsimp defer 1
proof -
  fix x
  assume xI: "x \<in> I"
  have ZJ: "\<zero> \<in> J"
    by (intro additive_subgroup.zero_closed) (rule ideal.axioms[OF idealJ])
  from ideal.Icarr[OF idealI xI] have "x = x \<oplus> \<zero>"
    by algebra
  with xI and ZJ show "\<exists>h\<in>I. \<exists>k\<in>J. x = h \<oplus> k"
    by fast
next
  fix x
  assume xJ: "x \<in> J"
  have ZI: "\<zero> \<in> I"
    by (intro additive_subgroup.zero_closed, rule ideal.axioms[OF idealI])
  from ideal.Icarr[OF idealJ xJ] have "x = \<zero> \<oplus> x"
    by algebra
  with ZI and xJ show "\<exists>h\<in>I. \<exists>k\<in>J. x = h \<oplus> k"
    by fast
next
  fix i j K
  assume iI: "i \<in> I"
    and jJ: "j \<in> J"
    and idealK: "ideal K R"
    and IK: "I \<subseteq> K"
    and JK: "J \<subseteq> K"
  from iI and IK have iK: "i \<in> K" by fast
  from jJ and JK have jK: "j \<in> K" by fast
  from iK and jK show "i \<oplus> j \<in> K"
    by (intro additive_subgroup.a_closed) (rule ideal.axioms[OF idealK])
qed

subsection {* Properties of Principal Ideals *}

text {* @{text "\<zero>"} generates the zero ideal *}
lemma (in ring) zero_genideal: "Idl {\<zero>} = {\<zero>}"
  apply rule
  apply (simp add: genideal_minimal zeroideal)
  apply (fast intro!: genideal_self)
  done

text {* @{text "\<one>"} generates the unit ideal *}
lemma (in ring) one_genideal: "Idl {\<one>} = carrier R"
proof -
  have "\<one> \<in> Idl {\<one>}"
    by (simp add: genideal_self')
  then show "Idl {\<one>} = carrier R"
    by (intro ideal.one_imp_carrier) (fast intro: genideal_ideal)
qed

text {* The zero ideal is a principal ideal *}
corollary (in ring) zeropideal: "principalideal {\<zero>} R"
  apply (rule principalidealI)
   apply (rule zeroideal)
  apply (blast intro!: zero_genideal[symmetric])
  done

text {* The unit ideal is a principal ideal *}
corollary (in ring) onepideal: "principalideal (carrier R) R"
  apply (rule principalidealI)
   apply (rule oneideal)
  apply (blast intro!: one_genideal[symmetric])
  done

text {* Every principal ideal is a right coset of the carrier *}
lemma (in principalideal) rcos_generate:
  assumes "cring R"
  shows "\<exists>x\<in>I. I = carrier R #> x"
proof -
  interpret cring R by fact
  from generate obtain i where icarr: "i \<in> carrier R" and I1: "I = Idl {i}"
    by fast+

  from icarr and genideal_self[of "{i}"] have "i \<in> Idl {i}"
    by fast
  then have iI: "i \<in> I" by (simp add: I1)

  from I1 icarr have I2: "I = PIdl i"
    by (simp add: cgenideal_eq_genideal)

  have "PIdl i = carrier R #> i"
    unfolding cgenideal_def r_coset_def by fast

  with I2 have "I = carrier R #> i"
    by simp

  with iI show "\<exists>x\<in>I. I = carrier R #> x"
    by fast
qed

subsection {* Prime Ideals *}

lemma (in ideal) primeidealCD:
  assumes "cring R"
  assumes notprime: "\<not> primeideal I R"
  shows "carrier R = I \<or> (\<exists>a b. a \<in> carrier R \<and> b \<in> carrier R \<and> a \<otimes> b \<in> I \<and> a \<notin> I \<and> b \<notin> I)"
proof (rule ccontr, clarsimp)
  interpret cring R by fact
  assume InR: "carrier R \<noteq> I"
    and "\<forall>a. a \<in> carrier R \<longrightarrow> (\<forall>b. a \<otimes> b \<in> I \<longrightarrow> b \<in> carrier R \<longrightarrow> a \<in> I \<or> b \<in> I)"
  then have I_prime: "\<And> a b. \<lbrakk>a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> I\<rbrakk> \<Longrightarrow> a \<in> I \<or> b \<in> I"
    by simp
  have "primeideal I R"
    apply (rule primeideal.intro [OF is_ideal is_cring])
    apply (rule primeideal_axioms.intro)
     apply (rule InR)
    apply (erule (2) I_prime)
    done
  with notprime show False by simp
qed

lemma (in ideal) primeidealCE:
  assumes "cring R"
  assumes notprime: "\<not> primeideal I R"
  obtains "carrier R = I"
    | "\<exists>a b. a \<in> carrier R \<and> b \<in> carrier R \<and> a \<otimes> b \<in> I \<and> a \<notin> I \<and> b \<notin> I"
proof -
  interpret R: cring R by fact
  assume "carrier R = I ==> thesis"
    and "\<exists>a b. a \<in> carrier R \<and> b \<in> carrier R \<and> a \<otimes> b \<in> I \<and> a \<notin> I \<and> b \<notin> I \<Longrightarrow> thesis"
  then show thesis using primeidealCD [OF R.is_cring notprime] by blast
qed

text {* If @{text "{\<zero>}"} is a prime ideal of a commutative ring, the ring is a domain *}
lemma (in cring) zeroprimeideal_domainI:
  assumes pi: "primeideal {\<zero>} R"
  shows "domain R"
  apply (rule domain.intro, rule is_cring)
  apply (rule domain_axioms.intro)
proof (rule ccontr, simp)
  interpret primeideal "{\<zero>}" "R" by (rule pi)
  assume "\<one> = \<zero>"
  then have "carrier R = {\<zero>}" by (rule one_zeroD)
  from this[symmetric] and I_notcarr show False
    by simp
next
  interpret primeideal "{\<zero>}" "R" by (rule pi)
  fix a b
  assume ab: "a \<otimes> b = \<zero>" and carr: "a \<in> carrier R" "b \<in> carrier R"
  from ab have abI: "a \<otimes> b \<in> {\<zero>}"
    by fast
  with carr have "a \<in> {\<zero>} \<or> b \<in> {\<zero>}"
    by (rule I_prime)
  then show "a = \<zero> \<or> b = \<zero>" by simp
qed

corollary (in cring) domain_eq_zeroprimeideal: "domain R = primeideal {\<zero>} R"
  apply rule
   apply (erule domain.zeroprimeideal)
  apply (erule zeroprimeideal_domainI)
  done

subsection {* Maximal Ideals *}

lemma (in ideal) helper_I_closed:
  assumes carr: "a \<in> carrier R" "x \<in> carrier R" "y \<in> carrier R"
    and axI: "a \<otimes> x \<in> I"
  shows "a \<otimes> (x \<otimes> y) \<in> I"
proof -
  from axI and carr have "(a \<otimes> x) \<otimes> y \<in> I"
    by (simp add: I_r_closed)
  also from carr have "(a \<otimes> x) \<otimes> y = a \<otimes> (x \<otimes> y)"
    by (simp add: m_assoc)
  finally show "a \<otimes> (x \<otimes> y) \<in> I" .
qed

lemma (in ideal) helper_max_prime:
  assumes "cring R"
  assumes acarr: "a \<in> carrier R"
  shows "ideal {x\<in>carrier R. a \<otimes> x \<in> I} R"
proof -
  interpret cring R by fact
  show ?thesis apply (rule idealI)
    apply (rule cring.axioms[OF is_cring])
    apply (rule subgroup.intro)
    apply (simp, fast)
    apply clarsimp apply (simp add: r_distr acarr)
    apply (simp add: acarr)
    apply (simp add: a_inv_def[symmetric], clarify) defer 1
    apply clarsimp defer 1
    apply (fast intro!: helper_I_closed acarr)
  proof -
    fix x
    assume xcarr: "x \<in> carrier R"
      and ax: "a \<otimes> x \<in> I"
    from ax and acarr xcarr
    have "\<ominus>(a \<otimes> x) \<in> I" by simp
    also from acarr xcarr
    have "\<ominus>(a \<otimes> x) = a \<otimes> (\<ominus>x)" by algebra
    finally show "a \<otimes> (\<ominus>x) \<in> I" .
    from acarr have "a \<otimes> \<zero> = \<zero>" by simp
  next
    fix x y
    assume xcarr: "x \<in> carrier R"
      and ycarr: "y \<in> carrier R"
      and ayI: "a \<otimes> y \<in> I"
    from ayI and acarr xcarr ycarr have "a \<otimes> (y \<otimes> x) \<in> I"
      by (simp add: helper_I_closed)
    moreover
    from xcarr ycarr have "y \<otimes> x = x \<otimes> y"
      by (simp add: m_comm)
    ultimately
    show "a \<otimes> (x \<otimes> y) \<in> I" by simp
  qed
qed

text {* In a cring every maximal ideal is prime *}
lemma (in cring) maximalideal_is_prime:
  assumes "maximalideal I R"
  shows "primeideal I R"
proof -
  interpret maximalideal I R by fact
  show ?thesis apply (rule ccontr)
    apply (rule primeidealCE)
    apply (rule is_cring)
    apply assumption
    apply (simp add: I_notcarr)
  proof -
    assume "\<exists>a b. a \<in> carrier R \<and> b \<in> carrier R \<and> a \<otimes> b \<in> I \<and> a \<notin> I \<and> b \<notin> I"
    then obtain a b where
      acarr: "a \<in> carrier R" and
      bcarr: "b \<in> carrier R" and
      abI: "a \<otimes> b \<in> I" and
      anI: "a \<notin> I" and
      bnI: "b \<notin> I" by fast
    def J \<equiv> "{x\<in>carrier R. a \<otimes> x \<in> I}"

    from is_cring and acarr have idealJ: "ideal J R"
      unfolding J_def by (rule helper_max_prime)

    have IsubJ: "I \<subseteq> J"
    proof
      fix x
      assume xI: "x \<in> I"
      with acarr have "a \<otimes> x \<in> I"
        by (intro I_l_closed)
      with xI[THEN a_Hcarr] show "x \<in> J"
        unfolding J_def by fast
    qed

    from abI and acarr bcarr have "b \<in> J"
      unfolding J_def by fast
    with bnI have JnI: "J \<noteq> I" by fast
    from acarr
    have "a = a \<otimes> \<one>" by algebra
    with anI have "a \<otimes> \<one> \<notin> I" by simp
    with one_closed have "\<one> \<notin> J"
      unfolding J_def by fast
    then have Jncarr: "J \<noteq> carrier R" by fast

    interpret ideal J R by (rule idealJ)

    have "J = I \<or> J = carrier R"
      apply (intro I_maximal)
      apply (rule idealJ)
      apply (rule IsubJ)
      apply (rule a_subset)
      done

    with JnI and Jncarr show False by simp
  qed
qed

subsection {* Derived Theorems *}

--"A non-zero cring that has only the two trivial ideals is a field"
lemma (in cring) trivialideals_fieldI:
  assumes carrnzero: "carrier R \<noteq> {\<zero>}"
    and haveideals: "{I. ideal I R} = {{\<zero>}, carrier R}"
  shows "field R"
  apply (rule cring_fieldI)
  apply (rule, rule, rule)
   apply (erule Units_closed)
  defer 1
    apply rule
  defer 1
proof (rule ccontr, simp)
  assume zUnit: "\<zero> \<in> Units R"
  then have a: "\<zero> \<otimes> inv \<zero> = \<one>" by (rule Units_r_inv)
  from zUnit have "\<zero> \<otimes> inv \<zero> = \<zero>"
    by (intro l_null) (rule Units_inv_closed)
  with a[symmetric] have "\<one> = \<zero>" by simp
  then have "carrier R = {\<zero>}" by (rule one_zeroD)
  with carrnzero show False by simp
next
  fix x
  assume xcarr': "x \<in> carrier R - {\<zero>}"
  then have xcarr: "x \<in> carrier R" by fast
  from xcarr' have xnZ: "x \<noteq> \<zero>" by fast
  from xcarr have xIdl: "ideal (PIdl x) R"
    by (intro cgenideal_ideal) fast

  from xcarr have "x \<in> PIdl x"
    by (intro cgenideal_self) fast
  with xnZ have "PIdl x \<noteq> {\<zero>}" by fast
  with haveideals have "PIdl x = carrier R"
    by (blast intro!: xIdl)
  then have "\<one> \<in> PIdl x" by simp
  then have "\<exists>y. \<one> = y \<otimes> x \<and> y \<in> carrier R"
    unfolding cgenideal_def by blast
  then obtain y where ycarr: " y \<in> carrier R" and ylinv: "\<one> = y \<otimes> x"
    by fast+
  from ylinv and xcarr ycarr have yrinv: "\<one> = x \<otimes> y"
    by (simp add: m_comm)
  from ycarr and ylinv[symmetric] and yrinv[symmetric]
  have "\<exists>y \<in> carrier R. y \<otimes> x = \<one> \<and> x \<otimes> y = \<one>" by fast
  with xcarr show "x \<in> Units R"
    unfolding Units_def by fast
qed

lemma (in field) all_ideals: "{I. ideal I R} = {{\<zero>}, carrier R}"
  apply (rule, rule)
proof -
  fix I
  assume a: "I \<in> {I. ideal I R}"
  then interpret ideal I R by simp

  show "I \<in> {{\<zero>}, carrier R}"
  proof (cases "\<exists>a. a \<in> I - {\<zero>}")
    case True
    then obtain a where aI: "a \<in> I" and anZ: "a \<noteq> \<zero>"
      by fast+
    from aI[THEN a_Hcarr] anZ have aUnit: "a \<in> Units R"
      by (simp add: field_Units)
    then have a: "a \<otimes> inv a = \<one>" by (rule Units_r_inv)
    from aI and aUnit have "a \<otimes> inv a \<in> I"
      by (simp add: I_r_closed del: Units_r_inv)
    then have oneI: "\<one> \<in> I" by (simp add: a[symmetric])

    have "carrier R \<subseteq> I"
    proof
      fix x
      assume xcarr: "x \<in> carrier R"
      with oneI have "\<one> \<otimes> x \<in> I" by (rule I_r_closed)
      with xcarr show "x \<in> I" by simp
    qed
    with a_subset have "I = carrier R" by fast
    then show "I \<in> {{\<zero>}, carrier R}" by fast
  next
    case False
    then have IZ: "\<And>a. a \<in> I \<Longrightarrow> a = \<zero>" by simp

    have a: "I \<subseteq> {\<zero>}"
    proof
      fix x
      assume "x \<in> I"
      then have "x = \<zero>" by (rule IZ)
      then show "x \<in> {\<zero>}" by fast
    qed

    have "\<zero> \<in> I" by simp
    then have "{\<zero>} \<subseteq> I" by fast

    with a have "I = {\<zero>}" by fast
    then show "I \<in> {{\<zero>}, carrier R}" by fast
  qed
qed (simp add: zeroideal oneideal)

--"Jacobson Theorem 2.2"
lemma (in cring) trivialideals_eq_field:
  assumes carrnzero: "carrier R \<noteq> {\<zero>}"
  shows "({I. ideal I R} = {{\<zero>}, carrier R}) = field R"
  by (fast intro!: trivialideals_fieldI[OF carrnzero] field.all_ideals)

text {* Like zeroprimeideal for domains *}
lemma (in field) zeromaximalideal: "maximalideal {\<zero>} R"
  apply (rule maximalidealI)
    apply (rule zeroideal)
proof-
  from one_not_zero have "\<one> \<notin> {\<zero>}" by simp
  with one_closed show "carrier R \<noteq> {\<zero>}" by fast
next
  fix J
  assume Jideal: "ideal J R"
  then have "J \<in> {I. ideal I R}" by fast
  with all_ideals show "J = {\<zero>} \<or> J = carrier R"
    by simp
qed

lemma (in cring) zeromaximalideal_fieldI:
  assumes zeromax: "maximalideal {\<zero>} R"
  shows "field R"
  apply (rule trivialideals_fieldI, rule maximalideal.I_notcarr[OF zeromax])
  apply rule apply clarsimp defer 1
   apply (simp add: zeroideal oneideal)
proof -
  fix J
  assume Jn0: "J \<noteq> {\<zero>}"
    and idealJ: "ideal J R"
  interpret ideal J R by (rule idealJ)
  have "{\<zero>} \<subseteq> J" by (rule ccontr) simp
  from zeromax and idealJ and this and a_subset
  have "J = {\<zero>} \<or> J = carrier R"
    by (rule maximalideal.I_maximal)
  with Jn0 show "J = carrier R"
    by simp
qed

lemma (in cring) zeromaximalideal_eq_field: "maximalideal {\<zero>} R = field R"
  apply rule
   apply (erule zeromaximalideal_fieldI)
  apply (erule field.zeromaximalideal)
  done

end


theory BTree_Height
  imports BTree
begin

section "Maximum and minimum height"

text "Textbooks usually provide some proofs relating the maxmimum and minimum height of the BTree
for a given number of nodes. We therefore introduce this counting and show the respective proofs."

subsection "Definition of node/size"

thm BTree.btree.size
  (* the automatically derived size is a bit weird for our purposes *)
value "size (Node [(Leaf, (0::nat)), (Node [(Leaf, 1), (Leaf, 10)] Leaf, 12), (Leaf, 30), (Leaf, 100)] Leaf)"

text "The default size function does not suit our needs as it regards the length of the list in each node.
 We would like to count the number of nodes in the tree only, not regarding the number of keys."

(* we want a different counting method,
  namely only the number of nodes in a tree *)

(* TODO what if we count Leafs as nodes? *)

fun nodes::"'a btree \<Rightarrow> nat" where
  "nodes Leaf = 0" |
  "nodes (Node ts t) = 1 + (\<Sum>t\<leftarrow>subtrees ts. nodes t) + (nodes t)"

value "nodes (Node [(Leaf, (0::nat)), (Node [(Leaf, 1), (Leaf, 10)] Leaf, 12), (Leaf, 30), (Leaf, 100)] Leaf)"

(* maximum number of nodes for given height *)
subsection "Maximum number of nodes for a given height"

lemma sum_list_replicate: "sum_list (replicate n c) = n*c"
  apply(induction n)
   apply(auto simp add: ring_class.ring_distribs(2))
  done

abbreviation "bound k h \<equiv> ((k+1)^h - 1)"

lemma nodes_height_upper_bound:
  "\<lbrakk>order k t; bal t\<rbrakk> \<Longrightarrow> nodes t * (2*k) \<le> bound (2*k) (height t)"
proof(induction t rule: nodes.induct)
  case (2 ts t)
  let ?sub_height = "((2 * k + 1) ^ height t - 1)"
  have "sum_list (map nodes (subtrees ts)) * (2*k) =
        sum_list (map (\<lambda>t. nodes t * (2 * k)) (subtrees ts))"
    using sum_list_mult_const by metis
  also have "\<dots> \<le> sum_list (map (\<lambda>x.?sub_height) (subtrees ts))"
    using 2
    using sum_list_mono[of "subtrees ts" "\<lambda>t. nodes t * (2 * k)" "\<lambda>x. bound (2 * k) (height t)"]
    by (metis bal.simps(2) order.simps(2))
  also have "\<dots> = sum_list (replicate (length ts) ?sub_height)"
    using map_replicate_const[of ?sub_height "subtrees ts"] length_map
    by simp
  also have "\<dots> = (length ts)*(?sub_height)"
    using sum_list_replicate by simp
  also have "\<dots> \<le> (2*k)*(?sub_height)"
    using "2.prems"(1)
    by simp
  finally have "sum_list (map nodes (subtrees ts))*(2*k) \<le> ?sub_height*(2*k)"
    by simp
  moreover have "(nodes t)*(2*k) \<le> ?sub_height"
    using 2 by simp
  ultimately have "(nodes (Node ts t))*(2*k) \<le>
         2*k
        + ?sub_height * (2*k)
        + ?sub_height"
    unfolding nodes.simps add_mult_distrib
    by linarith
  also have "\<dots> =  2*k + (2*k)*((2 * k + 1) ^ height t) - 2*k + (2 * k + 1) ^ height t - 1"
    by (simp add: diff_mult_distrib2 mult.assoc mult.commute)
  also have "\<dots> = (2*k)*((2 * k + 1) ^ height t) + (2 * k + 1) ^ height t - 1"
    by simp
  also have "\<dots> = (2*k+1)^(Suc(height t)) - 1"
    by simp
  finally show ?case
    by (metis "2.prems"(2) height_bal_tree)
qed simp

text "To verify our lower bound is sharp, we compare it to the height of artificially constructed
full trees."

fun full_node::"nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a btree" where
  "full_node k c 0 = Leaf"|
  "full_node k c (Suc n) = (Node (replicate (2*k) ((full_node k c n),c)) (full_node k c n))"

value "let k = (2::nat) in map (\<lambda>x. nodes x * 2*k) (map (full_node k (1::nat)) [0,1,2,3,4])"
value "let k = (2::nat) in map (\<lambda>x. ((2*k+(1::nat))^(x)-1)) [0,1,2,3,4]"

lemma compow_comp_id: "c > 0 \<Longrightarrow> f \<circ> f = f \<Longrightarrow> (f ^^ c) = f"
  apply(induction c)
   apply auto
  by fastforce

(* required only for the fold definition of height *)
lemma compow_id_point: "f x = x \<Longrightarrow> (f ^^ c) x = x"
  apply(induction c)
   apply auto
  done

lemma height_full_node: "height (full_node k a h) = h"
  apply(induction k a h rule: full_node.induct)
   apply (auto simp add: set_replicate_conv_if)
  done

lemma bal_full_node: "bal (full_node k a h)"
  apply(induction k a h rule: full_node.induct)
   apply auto
  done

lemma order_full_node: "order k (full_node k a h)"
  apply(induction k a h rule: full_node.induct)
   apply auto
  done

lemma full_btrees_sharp: "nodes (full_node k a h) * (2*k) = bound (2*k) h"
  apply(induction k a h rule: full_node.induct)
   apply (auto simp add: height_full_node algebra_simps sum_list_replicate)
  done

lemma upper_bound_sharp_node:
  "t = full_node k a h \<Longrightarrow> height t = h \<and> order k t \<and> bal t \<and> bound (2*k) h = nodes t * (2*k)"
  by (simp add: bal_full_node height_full_node order_full_node full_btrees_sharp)

(* maximum number of nodes *)
subsection "Maximum height for a given number of nodes"

lemma nodes_height_lower_bound:
  "\<lbrakk>order k t; bal t\<rbrakk> \<Longrightarrow> bound k (height t) \<le> nodes t * k"
proof(induction t rule: nodes.induct)
  case (2 ts t)
  let ?sub_height = "((k + 1) ^ height t - 1)"
  have "k*(?sub_height) \<le> (length ts)*(?sub_height)"
    using "2.prems"(1)
    by simp
  also have "\<dots> = sum_list (replicate (length ts) ?sub_height)"
    using sum_list_replicate by simp
  also have "\<dots> = sum_list (map (\<lambda>x.?sub_height) (subtrees ts))"
    using map_replicate_const[of ?sub_height "subtrees ts"] length_map
    by simp
  also have "\<dots> \<le> sum_list (map (\<lambda>t. nodes t * k) (subtrees ts))"
    using 2
    using sum_list_mono[of "subtrees ts" "\<lambda>x. bound k (height t)" "\<lambda>t. nodes t * k"]
    by (metis bal.simps(2) order.simps(2))
  also have "\<dots> = sum_list (map nodes (subtrees ts)) * k"
    using sum_list_mult_const[of nodes k "subtrees ts"] by auto
  finally have "sum_list (map nodes (subtrees ts))*k \<ge> ?sub_height*k"
    by simp
  moreover have "(nodes t)*k \<ge> ?sub_height"
    using 2 by simp
  ultimately have "(nodes (Node ts t))*k \<ge>
        k
        + ?sub_height * k
        + ?sub_height"
    unfolding nodes.simps add_mult_distrib
    by linarith
  also have
    "k + ?sub_height * k + ?sub_height =
     k + k*((k + 1) ^ height t) - k + (k + 1) ^ height t - 1"
    by (simp add: diff_mult_distrib2 mult.assoc mult.commute)
  also have "\<dots> = k*((k + 1) ^ height t) + (k + 1) ^ height t - 1"
    by simp
  also have "\<dots> = (k+1)^(Suc(height t)) - 1"
    by simp
  finally show ?case
    by (metis "2.prems"(2) height_bal_tree)
qed simp

text "To verify our upper bound is sharp, we compare it to the height of artificially constructed
minimally filled (=slim) trees."

fun slim_node::"nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a btree" where
  "slim_node k c 0 = Leaf"|
  "slim_node k c (Suc n) = (Node (replicate k ((slim_node k c n),c)) (slim_node k c n))"

value "let k = (2::nat) in map (\<lambda>x. nodes x * k) (map (slim_node k (1::nat)) [0,1,2,3,4])"
value "let k = (2::nat) in map (\<lambda>x. ((k+1::nat)^(x)-1)) [0,1,2,3,4]"

lemma height_slim_node: "height (slim_node k a h) = h"
  apply(induction k a h rule: full_node.induct)
   apply (auto simp add: set_replicate_conv_if)
  done

lemma bal_slim_node: "bal (slim_node k a h)"
  apply(induction k a h rule: full_node.induct)
   apply auto
  done

lemma order_slim_node: "order k (slim_node k a h)"
  apply(induction k a h rule: full_node.induct)
   apply auto
  done

lemma slim_nodes_sharp: "nodes (slim_node k a h) * k = bound k h"
  apply(induction k a h rule: slim_node.induct)
   apply (auto simp add: height_slim_node algebra_simps sum_list_replicate compow_id_point)
  done

lemma lower_bound_sharp_node:
  "t = slim_node k a h \<Longrightarrow> height t = h \<and> order k t \<and> bal t \<and> bound k h = nodes t * k"
  by (simp add: bal_slim_node height_slim_node order_slim_node slim_nodes_sharp)

(* TODO results for root_order/bal *)
text "Since BTrees have special roots, we need to show the overall nodes seperately"

lemma nodes_root_height_lower_bound:
  assumes "root_order k t"
    and "bal t"
  shows "2*((k+1)^(height t - 1) - 1) + (of_bool (t \<noteq> Leaf))*k  \<le> nodes t * k"
proof (cases t)
  case (Node ts t)
  let ?sub_height = "((k + 1) ^ height t - 1)"
  from Node have "?sub_height \<le> length ts * ?sub_height"
    using assms
    by (simp add: Suc_leI)
  also have "\<dots> = sum_list (replicate (length ts) ?sub_height)"
    using sum_list_replicate
    by simp
  also have "\<dots> = sum_list (map (\<lambda>x. ?sub_height) (subtrees ts))"
    using map_replicate_const[of ?sub_height "subtrees ts"] length_map
    by simp
  also have "\<dots> \<le> sum_list (map (\<lambda>t. nodes t * k) (subtrees ts))"
    using Node
      sum_list_mono[of "subtrees ts" "\<lambda>x. (k+1)^(height t) - 1" "\<lambda>x. nodes x * k"]
      nodes_height_lower_bound assms
    by fastforce
  also have "\<dots> = sum_list (map nodes (subtrees ts)) * k"
    using sum_list_mult_const[of nodes k "subtrees ts"] by simp
  finally have "sum_list (map nodes (subtrees ts))*k \<ge> ?sub_height"
    by simp

  moreover have "(nodes t)*k \<ge> ?sub_height"
    using Node assms nodes_height_lower_bound
    by auto
  ultimately have "(nodes (Node ts t))*k \<ge>
        ?sub_height
        + ?sub_height + k"
    unfolding nodes.simps add_mult_distrib
    by linarith
  then show ?thesis
    using Node assms(2) height_bal_tree by fastforce
qed simp

lemma nodes_root_height_upper_bound:
  assumes "root_order k t"
    and "bal t"
  shows "nodes t * (2*k) \<le> (2*k+1)^(height t) - 1"
proof(cases t)
  case (Node ts t)
  let ?sub_height = "((2 * k + 1) ^ height t - 1)"
  have "sum_list (map nodes (subtrees ts)) * (2*k) =
        sum_list (map (\<lambda>t. nodes t * (2 * k)) (subtrees ts))"
    using sum_list_mult_const by metis
  also have "\<dots> \<le> sum_list (map (\<lambda>x.?sub_height) (subtrees ts))"
    using Node
      sum_list_mono[of "subtrees ts" "\<lambda>x. nodes x * (2*k)"  "\<lambda>x. (2*k+1)^(height t) - 1"]
      nodes_height_upper_bound assms
    by fastforce
  also have "\<dots> = sum_list (replicate (length ts) ?sub_height)"
    using map_replicate_const[of ?sub_height "subtrees ts"] length_map
    by simp
  also have "\<dots> = (length ts)*(?sub_height)"
    using sum_list_replicate by simp
  also have "\<dots> \<le> (2*k)*?sub_height"
    using assms Node
    by simp
  finally have "sum_list (map nodes (subtrees ts))*(2*k) \<le> ?sub_height*(2*k)"
    by simp
  moreover have "(nodes t)*(2*k) \<le> ?sub_height"
    using Node assms nodes_height_upper_bound
    by auto
  ultimately have "(nodes (Node ts t))*(2*k) \<le>
         2*k
        + ?sub_height * (2*k)
        + ?sub_height"
    unfolding nodes.simps add_mult_distrib
    by linarith
  also have "\<dots> =  2*k + (2*k)*((2 * k + 1) ^ height t) - 2*k + (2 * k + 1) ^ height t - 1"
    by (simp add: diff_mult_distrib2 mult.assoc mult.commute)
  also have "\<dots> = (2*k)*((2 * k + 1) ^ height t) + (2 * k + 1) ^ height t - 1"
    by simp
  also have "\<dots> = (2*k+1)^(Suc(height t)) - 1"
    by simp
  finally show ?thesis
    by (metis Node assms(2) height_bal_tree)
qed simp

lemma root_order_imp_divmuleq: "root_order k t \<Longrightarrow> (nodes t * k) div k = nodes t"
  using root_order.elims(2) by fastforce

lemma nodes_root_height_lower_bound_simp:
  assumes "root_order k t"
    and "bal t"
    and "k > 0"
  shows "(2*((k+1)^(height t - 1) - 1)) div k + (of_bool (t \<noteq> Leaf)) \<le> nodes t"
proof (cases t)
  case Node
  have "(2*((k+1)^(height t - 1) - 1)) div k + (of_bool (t \<noteq> Leaf)) =
(2*((k+1)^(height t - 1) - 1) + (of_bool (t \<noteq> Leaf))*k) div k"
    using Node assms
    using div_plus_div_distrib_dvd_left[of k k "(2 * Suc k ^ (height t - Suc 0) - Suc (Suc 0))"]
    by (auto simp add: algebra_simps simp del: height_btree.simps)
  also have "\<dots> \<le> (nodes t * k) div k"
    using nodes_root_height_lower_bound[OF assms(1,2)] div_le_mono
    by blast
  also have "\<dots> = nodes t"
    using root_order_imp_divmuleq[OF assms(1)]
    by simp
  finally show ?thesis .
qed simp

lemma nodes_root_height_upper_bound_simp:
  assumes "root_order k t"
    and "bal t"
  shows "nodes t \<le> ((2*k+1)^(height t) - 1) div (2*k)"
proof -
  have "nodes t = (nodes t * (2*k)) div (2*k)"
    using root_order_imp_divmuleq[OF assms(1)]
    by simp
  also have "\<dots> \<le> ((2*k+1)^(height t) - 1) div (2*k)"
    using div_le_mono nodes_root_height_upper_bound[OF assms] by blast
  finally show ?thesis .
qed

definition "full_tree = full_node"

fun slim_tree where
  "slim_tree k c 0 = Leaf" |
  "slim_tree k c (Suc h) = Node [(slim_node k c h, c)] (slim_node k c h)"

lemma lower_bound_sharp:
  "k > 0 \<Longrightarrow> t = slim_tree k a h \<Longrightarrow> height t = h \<and> root_order k t \<and> bal t \<and> nodes t * k = 2*((k+1)^(height t - 1) - 1) + (of_bool (t \<noteq> Leaf))*k"
  apply (cases h)
  using slim_nodes_sharp[of k a]
   apply (auto simp add: algebra_simps bal_slim_node height_slim_node order_slim_node)
  done

lemma upper_bound_sharp:
  "k > 0 \<Longrightarrow> t = full_tree k a h \<Longrightarrow> height t = h \<and> root_order k t \<and> bal t \<and> ((2*k+1)^(height t) - 1) = nodes t * (2*k)"
  unfolding full_tree_def
  using order_impl_root_order[of k t]
  by (simp add: bal_full_node height_full_node order_full_node full_btrees_sharp)

end


(*
    File:      Dirichlet_Characters.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>Dirichlet Characters\<close>
theory Dirichlet_Characters
imports
  Multiplicative_Characters
  "HOL-Number_Theory.Residues"
  "Dirichlet_Series.Multiplicative_Function"
begin

text \<open>
  Dirichlet characters are essentially just the characters of the multiplicative group of
  integer residues $\mathbb{ZZ}/n\mathbb{ZZ}$ for some fixed $n$. For convenience, these residues
  are usually represented by natural numbers from $0$ to $n - 1$, and we extend the characters to
  all natural numbers periodically, so that $\chi(k\mod n) = \chi(k)$ holds.

  Numbers that are not coprime to $n$ are not in the group and therefore are assigned $0$ by
  all characters.
\<close>

subsection \<open>The multiplicative group of residues\<close>

definition residue_mult_group :: "nat \<Rightarrow> nat monoid" where
  "residue_mult_group n = \<lparr> carrier = totatives n, monoid.mult = (\<lambda>x y. (x * y) mod n), one = 1 \<rparr>"

definition principal_dchar :: "nat \<Rightarrow> nat \<Rightarrow> complex" where
  "principal_dchar n = (\<lambda>k. if coprime k n then 1 else 0)"

lemma principal_dchar_coprime [simp]: "coprime k n \<Longrightarrow> principal_dchar n k = 1"
  and principal_dchar_not_coprime [simp]: "\<not>coprime k n \<Longrightarrow> principal_dchar n k = 0"
  by (simp_all add: principal_dchar_def)

lemma principal_dchar_1 [simp]: "principal_dchar n 1 = 1"
  by simp

lemma principal_dchar_minus1 [simp]:
  assumes "n > 0"
  shows   "principal_dchar n (n - Suc 0) = 1"
proof (cases "n = 1")
  case False
  with assms have "n > 1" by linarith
  thus ?thesis using coprime_diff_one_left_nat[of n]
    by (intro principal_dchar_coprime) auto
qed auto

lemma mod_in_totatives: "n > 1 \<Longrightarrow> a mod n \<in> totatives n \<longleftrightarrow> coprime a n"
  by (auto simp: totatives_def mod_greater_zero_iff_not_dvd dest: coprime_common_divisor_nat)

bundle dcharacter_syntax
begin
notation principal_dchar ("\<chi>\<^sub>0\<index>")
end

locale residues_nat =
  fixes n :: nat (structure) and G
  assumes n: "n > 1"
  defines "G \<equiv> residue_mult_group n"
begin

lemma order [simp]: "order G = totient n"
  by (simp add: order_def G_def totient_def residue_mult_group_def)

lemma totatives_mod [simp]: "x \<in> totatives n \<Longrightarrow> x mod n = x"
  using n by (intro mod_less) (auto simp: totatives_def intro!: order.not_eq_order_implies_strict)

lemma principal_dchar_minus1 [simp]: "principal_dchar n (n - Suc 0) = 1"
  using principal_dchar_minus1[of n] n by simp

sublocale finite_comm_group G
proof
  fix x y assume xy: "x \<in> carrier G" "y \<in> carrier G"
  hence "coprime (x * y) n"
    by (auto simp: G_def residue_mult_group_def totatives_def)
  with xy and n show "x \<otimes>\<^bsub>G\<^esub> y \<in> carrier G"
    using coprime_common_divisor_nat[of "x * y" n]
    by (auto simp: G_def residue_mult_group_def totatives_def
                   mod_greater_zero_iff_not_dvd le_Suc_eq simp del: coprime_mult_left_iff)
next
  fix x y z assume xyz: "x \<in> carrier G" "y \<in> carrier G" "z \<in> carrier G"
  thus "x \<otimes>\<^bsub>G\<^esub> y \<otimes>\<^bsub>G\<^esub> z = x \<otimes>\<^bsub>G\<^esub> (y \<otimes>\<^bsub>G\<^esub> z)"
    by (auto simp: G_def residue_mult_group_def mult_ac mod_mult_right_eq)
next
  fix x assume "x \<in> carrier G"
  with n have "x < n" by (auto simp: G_def residue_mult_group_def totatives_def
                               intro!: order.not_eq_order_implies_strict)
  thus " \<one>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x = x" and "x \<otimes>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub> = x"
    by (simp_all add: G_def residue_mult_group_def)
next
  have "x \<in> Units G" if "x \<in> carrier G" for x unfolding Units_def
  proof safe
    from that have "x > 0" "coprime x n"
      by (auto simp: G_def residue_mult_group_def totatives_def)
    from \<open>coprime x n\<close> and n obtain y where y: "y < n" "[x * y = 1] (mod n)"
      by (subst (asm) coprime_iff_invertible'_nat) auto
    hence "x * y mod n = 1"
      using n by (simp add: cong_def mult_ac)
    moreover from y have "coprime y n"
      by (subst coprime_iff_invertible_nat) (auto simp: mult.commute)
    ultimately show "\<exists>a\<in>carrier G. a \<otimes>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> \<and> x \<otimes>\<^bsub>G\<^esub> a = \<one>\<^bsub>G\<^esub>" using y
      by (intro bexI[of _ y])
         (auto simp: G_def residue_mult_group_def totatives_def mult.commute intro!: Nat.gr0I)
  qed fact+
  thus "carrier G \<subseteq> Units G" ..
qed (insert n, auto simp: G_def residue_mult_group_def mult_ac)

subsection \<open>Definition of Dirichlet characters\<close>

text \<open>
  The following two functions make the connection between Dirichlet characters and the
  multiplicative characters of the residue group.
\<close>
definition c2dc :: "(nat \<Rightarrow> complex) \<Rightarrow> (nat \<Rightarrow> complex)" where
  "c2dc \<chi> = (\<lambda>x. \<chi> (x mod n))"

definition dc2c :: "(nat \<Rightarrow> complex) \<Rightarrow> (nat \<Rightarrow> complex)" where
  "dc2c \<chi> = (\<lambda>x. if x < n then \<chi> x else 0)"

lemma dc2c_c2dc [simp]:
  assumes "character G \<chi>"
  shows   "dc2c (c2dc \<chi>) = \<chi>"
proof -
  interpret character G \<chi> by fact
  show ?thesis
    using n by (auto simp: fun_eq_iff dc2c_def c2dc_def char_eq_0_iff G_def
                           residue_mult_group_def totatives_def)
qed

end

locale dcharacter = residues_nat +
  fixes \<chi> :: "nat \<Rightarrow> complex"
  assumes mult_aux: "a \<in> totatives n \<Longrightarrow> b \<in> totatives n \<Longrightarrow> \<chi> (a * b) = \<chi> a * \<chi> b"
  assumes eq_zero:  "\<not>coprime a n \<Longrightarrow> \<chi> a = 0"
  assumes periodic: "\<chi> (a + n) = \<chi> a"
  assumes one_not_zero: "\<chi> 1 \<noteq> 0"
begin

lemma zero_eq_0 [simp]: "\<chi> 0 = 0"
  using n by (intro eq_zero) auto

lemma Suc_0 [simp]: "\<chi> (Suc 0) = 1"
  using n mult_aux[of 1 1] one_not_zero by (simp add: totatives_def)

lemma periodic_mult: "\<chi> (a + m * n) = \<chi> a"
proof (induction m)
  case (Suc m)
  have "a + Suc m * n = a + m * n+ n" by simp
  also have "\<chi> \<dots> = \<chi> (a + m * n)" by (rule periodic)
  also have "\<dots> = \<chi> a" by (rule Suc.IH)
  finally show ?case .
qed simp_all

lemma minus_one_periodic [simp]:
  assumes "k > 0"
  shows   "\<chi> (k * n - 1) = \<chi> (n - 1)"
proof -
  have "k * n - 1 = n - 1 + (k - 1) * n"
    using assms n by (simp add: algebra_simps)
  also have "\<chi> \<dots> = \<chi> (n - 1)"
    by (rule periodic_mult)
  finally show ?thesis .
qed

lemma cong:
  assumes "[a = b] (mod n)"
  shows   "\<chi> a = \<chi> b"
proof -
  from assms obtain k1 k2 where *: "b + k1 * n = a + k2 * n"
    by (subst (asm) cong_iff_lin_nat) auto
  have "\<chi> a = \<chi> (a + k2 * n)" by (rule periodic_mult [symmetric])
  also note * [symmetric]
  also have "\<chi> (b + k1 * n) = \<chi> b" by (rule periodic_mult)
  finally show ?thesis .
qed

lemma mod [simp]: "\<chi> (a mod n) = \<chi> a"
  by (rule cong) (simp_all add: cong_def)

lemma mult [simp]: "\<chi> (a * b) = \<chi> a * \<chi> b"
proof (cases "coprime a n \<and> coprime b n")
  case True
  hence "a mod n \<in> totatives n" "b mod n \<in> totatives n"
    using n by (auto simp: totatives_def mod_greater_zero_iff_not_dvd coprime_absorb_right)
  hence "\<chi> ((a mod n) * (b mod n)) = \<chi> (a mod n) * \<chi> (b mod n)"
    by (rule mult_aux)
  also have "\<chi> ((a mod n) * (b mod n)) = \<chi> (a * b)"
    by (rule cong) (auto simp: cong_def mod_mult_eq)
  finally show ?thesis by simp
next
  case False
  hence "\<not>coprime (a * b) n" by simp
  with False show ?thesis by (auto simp: eq_zero)
qed

sublocale mult: completely_multiplicative_function \<chi>
  by standard auto

lemma eq_zero_iff: "\<chi> x = 0 \<longleftrightarrow> \<not>coprime x n"
proof safe
  assume "\<chi> x = 0" and "coprime x n"
  from cong_solve_coprime_nat [OF this(2)]
    obtain y where "[x * y = Suc 0] (mod n)" by blast
  hence "\<chi> (x * y) = \<chi> (Suc 0)" by (rule cong)
  with \<open>\<chi> x = 0\<close> show False by simp
qed (auto simp: eq_zero)

lemma minus_one': "\<chi> (n - 1) \<in> {-1, 1}"
proof -
  define n' where "n' = n - 2"
  have n: "n = Suc (Suc n')" using n by (simp add: n'_def)
  have "(n - 1) ^ 2 = 1 + (n - 2) * n"
    by (simp add: power2_eq_square algebra_simps n)
  also have "\<chi> \<dots> = 1"
    by (subst periodic_mult) auto
  also have "\<chi> ((n - 1) ^ 2) = \<chi> (n - 1) ^ 2"
    by (rule mult.power)
  finally show ?thesis
    by (subst (asm) power2_eq_1_iff) auto
qed

lemma c2dc_dc2c [simp]: "c2dc (dc2c \<chi>) = \<chi>"
  using n by (auto simp: c2dc_def dc2c_def fun_eq_iff intro!: cong simp: cong_def)

lemma character_dc2c: "character G (dc2c \<chi>)"
  by standard (insert n, auto simp: G_def residue_mult_group_def dc2c_def totatives_def
                              intro!: eq_zero)

sublocale dc2c: character G "dc2c \<chi>"
  by (fact character_dc2c)

lemma dcharacter_inv_character [intro]: "dcharacter n (inv_character \<chi>)"
  by standard (auto simp: inv_character_def eq_zero periodic)

lemma norm: "norm (\<chi> k) = (if coprime k n then 1 else 0)"
proof -
  have "\<chi> k = \<chi> (k mod n)" by (intro cong) (auto simp: cong_def)
  also from n have "\<dots> = dc2c \<chi> (k mod n)" by (simp add: dc2c_def)
  also from n have "norm \<dots> = (if coprime k n then 1 else 0)"
    by (subst dc2c.norm_char) (auto simp: G_def residue_mult_group_def mod_in_totatives)
  finally show ?thesis .
qed

end

definition dcharacters :: "nat \<Rightarrow> (nat \<Rightarrow> complex) set" where
  "dcharacters n = {\<chi>. dcharacter n \<chi>}"

context residues_nat
begin

lemma character_dc2c: "dcharacter n \<chi> \<Longrightarrow> character G (dc2c \<chi>)"
  using dcharacter.character_dc2c[of n \<chi>] by (simp add: G_def)

lemma dcharacter_c2dc:
  assumes "character G \<chi>"
  shows   "dcharacter n (c2dc \<chi>)"
proof -
  interpret character G \<chi> by fact
  show ?thesis
  proof
    fix x assume "\<not>coprime x n"
    thus "c2dc \<chi> x = 0"
      by (auto simp: c2dc_def char_eq_0_iff G_def residue_mult_group_def totatives_def)
  qed (insert char_mult char_one n,
       auto simp: c2dc_def G_def residue_mult_group_def simp del: char_mult char_one)
qed

lemma principal_dchar_altdef: "principal_dchar n = c2dc (principal_char G)"
  using n by (auto simp: c2dc_def principal_dchar_def principal_char_def G_def
                residue_mult_group_def fun_eq_iff mod_in_totatives)

sublocale principal: dcharacter n G "principal_dchar n"
  by (simp add: principal_dchar_altdef dcharacter_c2dc | rule G_def)+

lemma c2dc_principal [simp]: "c2dc (principal_char G) = principal_dchar n"
  by (simp add: principal_dchar_altdef)

lemma dc2c_principal [simp]: "dc2c (principal_dchar n) = principal_char G"
proof -
  have "dc2c (c2dc (principal_char G)) = dc2c (principal_dchar n)"
    by (subst c2dc_principal) (rule refl)
  thus ?thesis by (subst (asm) dc2c_c2dc) simp_all
qed

lemma bij_betw_dcharacters_characters:
  "bij_betw dc2c (dcharacters n) (characters G)"
  by (intro bij_betwI[where ?g = c2dc])
     (auto simp: characters_def dcharacters_def dcharacter_c2dc
                 character_dc2c dcharacter.c2dc_dc2c)

lemma bij_betw_characters_dcharacters:
  "bij_betw c2dc (characters G) (dcharacters n)"
  by (intro bij_betwI[where ?g = dc2c])
     (auto simp: characters_def dcharacters_def dcharacter_c2dc
                 character_dc2c dcharacter.c2dc_dc2c)

lemma finite_dcharacters [intro]: "finite (dcharacters n)"
  using bij_betw_finite [OF bij_betw_dcharacters_characters] by auto

lemma card_dcharacters [simp]: "card (dcharacters n) = totient n"
  using bij_betw_same_card [OF bij_betw_dcharacters_characters] card_characters by simp

end

lemma inv_character_eq_principal_dchar_iff [simp]:
  "inv_character \<chi> = principal_dchar n \<longleftrightarrow> \<chi> = principal_dchar n"
  by (auto simp add: fun_eq_iff inv_character_def principal_dchar_def)

subsection \<open>Sums of Dirichlet characters\<close>

lemma (in dcharacter) sum_dcharacter_totatives:
  "(\<Sum>x\<in>totatives n. \<chi> x) = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
proof -
  from n have "(\<Sum>x\<in>totatives n. \<chi> x) = (\<Sum>x\<in>carrier G. dc2c \<chi> x)"
    by (intro sum.cong) (auto simp: totatives_def dc2c_def G_def residue_mult_group_def)
  also have "\<dots> = (if dc2c \<chi> = principal_char G then of_nat (order G) else 0)"
    by (rule dc2c.sum_character)
  also have "dc2c \<chi> = principal_char G \<longleftrightarrow> \<chi> = principal_dchar n"
    by (metis c2dc_dc2c dc2c_principal principal_dchar_altdef)
  finally show ?thesis by simp
qed

lemma (in dcharacter) sum_dcharacter_block:
  "(\<Sum>x<n. \<chi> x) = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
proof -
  from n have "(\<Sum>x<n. \<chi> x) = (\<Sum>x\<in>totatives n. \<chi> x)"
    by (intro sum.mono_neutral_right)
       (auto simp: totatives_def eq_zero_iff intro!: Nat.gr0I order.not_eq_order_implies_strict)
  also have "\<dots> = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
    by (rule sum_dcharacter_totatives)
  finally show ?thesis .
qed

lemma (in dcharacter) sum_dcharacter_block':
  "sum \<chi> {Suc 0..n} = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
proof -
  let ?f = "\<lambda>k. if k = n then 0 else k" and ?g = "\<lambda>k. if k = 0 then n else k"
  have "sum \<chi> {1..n} = sum \<chi> {..<n}"
    using n by (intro sum.reindex_bij_witness[where j = ?f and i = ?g]) (auto simp: eq_zero_iff)
  thus ?thesis by (simp add: sum_dcharacter_block)
qed

lemma (in dcharacter) sum_lessThan_dcharacter:
  assumes "\<chi> \<noteq> principal_dchar n"
  shows   "(\<Sum>x<m. \<chi> x) = (\<Sum>x<m mod n. \<chi> x)"
proof (induction m rule: less_induct)
  case (less m)
  show ?case
  proof (cases "m < n")
    case True
    thus ?thesis by simp
  next
    case False
    hence "{..<m} = {..<n} \<union> {n..<m}" by auto
    also have "(\<Sum>x\<in>\<dots>. \<chi> x) = (\<Sum>x<n. \<chi> x) + (\<Sum>x\<in>{n..<m}. \<chi> x)"
      by (intro sum.union_disjoint) auto
    also from assms have "(\<Sum>x<n. \<chi> x) = 0"
      by (subst sum_dcharacter_block) simp_all
    also from False have "(\<Sum>x\<in>{n..<m}. \<chi> x) = (\<Sum>x\<in>{..<m - n}. \<chi> (x + n))"
      by (intro sum.reindex_bij_witness[of _ "\<lambda>x. x + n" "\<lambda>x. x - n"]) (auto simp: periodic)
    also have "\<dots> = (\<Sum>x\<in>{..<m - n}. \<chi> x)" by (simp add: periodic)
    also have "\<dots> = (\<Sum>x<(m - n) mod n. \<chi> x)"
      using False and n by (intro less.IH) auto
    also from False and n have "(m - n) mod n = m mod n"
      by (simp add: mod_geq [symmetric])
    finally show ?thesis by simp
  qed
qed

lemma (in dcharacter) sum_dcharacter_lessThan_le:
  assumes "\<chi> \<noteq> principal_dchar n"
  shows   "norm (\<Sum>x<m. \<chi> x) \<le> totient n"
proof -
  have "(\<Sum>x<m. \<chi> x) = (\<Sum>x<m mod n. \<chi> x)" by (rule sum_lessThan_dcharacter) fact
  also have "\<dots> = (\<Sum>x | x < m mod n \<and> coprime x n. \<chi> x)"
    by (intro sum.mono_neutral_right) (auto simp: eq_zero_iff)
  also have "norm \<dots> \<le> (\<Sum>x | x < m mod n \<and> coprime x n. 1)"
    by (rule sum_norm_le) (auto simp: norm)
  also have "\<dots> = card {x. x < m mod n \<and> coprime x n}" by simp
  also have "\<dots> \<le> card (totatives n)" unfolding of_nat_le_iff
  proof (intro card_mono subsetI)
    fix x assume x: "x \<in> {x. x < m mod n \<and> coprime x n}"
    hence "x < m mod n" by simp
    also have "\<dots> < n" using n by simp
    finally show "x \<in> totatives n" using x
      by (auto simp: totatives_def intro!: Nat.gr0I)
  qed auto
  also have "\<dots> = totient n" by (simp add: totient_def)
  finally show ?thesis .
qed

lemma (in dcharacter) sum_dcharacter_atMost_le:
  assumes "\<chi> \<noteq> principal_dchar n"
  shows   "norm (\<Sum>x\<le>m. \<chi> x) \<le> totient n"
  using sum_dcharacter_lessThan_le[OF assms, of "Suc m"] by (subst (asm) lessThan_Suc_atMost)

lemma (in residues_nat) sum_dcharacters:
  "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = (if [x = 1] (mod n) then of_nat (totient n) else 0)"
proof (cases "coprime x n")
  case True
  with n have x: "x mod n \<in> totatives n" by (auto simp: mod_in_totatives)
  have "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = (\<Sum>\<chi>\<in>characters G. c2dc \<chi> x)"
    by (rule sum.reindex_bij_betw [OF bij_betw_characters_dcharacters, symmetric])
  also from x have "\<dots> = (\<Sum>\<chi>\<in>characters G. \<chi> (x mod n))"
    by (simp add: c2dc_def)
  also from x have "\<dots> = (if x mod n = 1 then order G else 0)"
    by (subst sum_characters) (unfold G_def residue_mult_group_def, auto)
  also from n have "x mod n = 1 \<longleftrightarrow> [x = 1] (mod n)"
    by (simp add: cong_def)
  finally show ?thesis by simp
next
  case False
  have "x mod n \<noteq> 1"
  proof
    assume *: "x mod n = 1"
    have "gcd (x mod n) n = 1" by (subst *) simp
    also have "gcd (x mod n) n = gcd x n"
      by (subst gcd.commute) (simp only: gcd_red_nat [symmetric])
    finally show False using \<open>\<not>coprime x n\<close> unfolding coprime_iff_gcd_eq_1 by contradiction
  qed
  from False have "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = 0"
    by (intro sum.neutral) (auto simp: dcharacters_def dcharacter.eq_zero)
  with \<open>x mod n \<noteq> 1\<close> and n show ?thesis by (simp add: cong_def)
qed

lemma (in dcharacter) even_dcharacter_linear_sum_eq_0 [simp]:
  assumes "\<chi> \<noteq> principal_dchar n" and "\<chi> (n - 1) = 1"
  shows   "(\<Sum>k=Suc 0..<n. of_nat k * \<chi> k) = 0"
proof -
  have "(\<Sum>k=1..<n. of_nat k * \<chi> k) = (\<Sum>k=1..<n. (of_nat n - of_nat k) * \<chi> (n - k))"
    by (intro sum.reindex_bij_witness[where i = "\<lambda>k. n - k" and j = "\<lambda>k. n - k"])
       (auto simp: of_nat_diff)
  also have "\<dots> = n * (\<Sum>k=1..<n. \<chi> (n - k)) - (\<Sum>k=1..<n. k * \<chi> (n - k))"
    by (simp add: algebra_simps sum_subtractf sum_distrib_left)
  also have "(\<Sum>k=1..<n. \<chi> (n - k)) = (\<Sum>k=1..<n. \<chi> k)"
    by (intro sum.reindex_bij_witness[where i = "\<lambda>k. n - k" and j = "\<lambda>k. n - k"]) auto
  also have "\<dots> = (\<Sum>k<n. \<chi> k)"
    by (intro sum.mono_neutral_left) (auto simp: Suc_le_eq)
  also have "\<dots> = 0" using assms by (simp add: sum_dcharacter_block)
  also have "(\<Sum>k=1..<n. of_nat k * \<chi> (n - k)) = (\<Sum>k=1..<n. k * \<chi> k)"
  proof (intro sum.cong refl)
    fix k assume k: "k \<in> {1..<n}"
    have "of_nat k * \<chi> k = of_nat k * \<chi> ((n - 1) * k)"
      using assms by (subst mult) simp_all
    also have "(n - 1) * k = n - k + (k - 1) * n"
      using k by (simp add: algebra_simps)
    also have "\<chi> \<dots> = \<chi> (n - k)"
      by (rule periodic_mult)
    finally show "of_nat k * \<chi> (n - k) = of_nat k * \<chi> k" ..
  qed
  finally show ?thesis by simp
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_ISortCount
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun count :: "'a => 'a list => Nat" where
"count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (isort xs)) = (count x xs))"
  oops

end


section {* Monoid variants and extra properties *}

theory Monoid_extra
  imports List_extra "~~/src/HOL/Library/Prefix_Order"
begin

class ordered_semigroup = semigroup_add + order +
  assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
  and add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
begin

lemma add_mono:
  "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
  using local.add_left_mono local.add_right_mono local.order.trans by blast

end

thm cancel_semigroup_add_axioms

class left_cancel_monoid = monoid_add +
  assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"

class right_cancel_monoid = monoid_add +
  assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"

class monoid_sum_0 = monoid_add +
  assumes zero_sum_left: "a + b = 0 \<Longrightarrow> a = 0"
begin

lemma zero_sum_right: "a + b = 0 \<Longrightarrow> b = 0"
  by (metis local.add_0_left local.zero_sum_left)

lemma zero_sum: "a + b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
  by (metis local.add_0_right zero_sum_right)

end

context monoid_add
begin

definition monoid_le (infix "\<le>\<^sub>m" 50)
where "a \<le>\<^sub>m b \<longleftrightarrow> (\<exists>c. b = a + c)"

definition monoid_subtract (infixl "-\<^sub>m" 65)
where "a -\<^sub>m b = (if (b \<le>\<^sub>m a) then THE c. a = b + c else 0)"

end

class cancel_monoid = left_cancel_monoid + right_cancel_monoid + monoid_sum_0
begin

lemma monoid_le_least_zero: "0 \<le>\<^sub>m a"
  by (simp add: monoid_le_def)

lemma monoid_le_refl: "a \<le>\<^sub>m a"
  by (simp add: monoid_le_def, metis add.right_neutral)

lemma monoid_le_trans: "\<lbrakk> a \<le>\<^sub>m b; b \<le>\<^sub>m c \<rbrakk> \<Longrightarrow> a \<le>\<^sub>m c"
  by (metis add.assoc monoid_le_def)

lemma monoid_le_antisym:
  assumes "a \<le>\<^sub>m b" "b \<le>\<^sub>m a"
  shows "a = b"
proof -
  obtain a' where a': "b = a + a'"
    using assms(1) monoid_le_def by auto

  obtain b' where b': "a = b + b'"
    using assms(2) monoid_le_def by auto

  have "b' = (b' + a' + b')"
    by (metis a' add_assoc b' local.add_left_imp_eq)

  hence "a' + b' = 0"
    by (metis add_assoc local.add_0_right local.add_left_imp_eq)

  hence "a' = 0" "b' = 0"
    by (simp add: zero_sum)+

  with a' b' show ?thesis
    by simp
qed

lemma monoid_le_add: "a \<le>\<^sub>m a + b"
  by (auto simp add: monoid_le_def)

lemma monoid_le_add_left_mono: "a \<le>\<^sub>m b \<Longrightarrow> c + a \<le>\<^sub>m c + b"
  using add_assoc by (auto simp add: monoid_le_def)

lemma add_monoid_diff_cancel_left [simp]: "(a + b) -\<^sub>m a = b"
  apply (simp add: monoid_subtract_def monoid_le_add)
  apply (rule the_equality)
  apply (simp)
  using local.add_left_imp_eq apply blast
done

end

class ordered_cancel_monoid_diff = cancel_monoid + ord + minus +
  assumes le_is_monoid_le: "a \<le> b \<longleftrightarrow> (a \<le>\<^sub>m b)"
  and less_iff: "a < b \<longleftrightarrow> a \<le> b \<and> \<not> (b \<le> a)"
  and minus_def: "a - b = a -\<^sub>m b"

instance ordered_cancel_monoid_diff \<subseteq> order
  apply (intro_classes)
  apply (simp_all add: less_iff le_is_monoid_le monoid_le_refl)
  using monoid_le_trans apply blast
  apply (simp add: monoid_le_antisym)
done

context ordered_cancel_monoid_diff
begin

  lemma le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists> c. b = a + c)"
    by (simp add: local.le_is_monoid_le local.monoid_le_def)

  lemma least_zero [simp]: "0 \<le> a"
    by (simp add: local.le_is_monoid_le local.monoid_le_least_zero)

  lemma le_add [simp]: "a \<le> a + b"
    by (simp add: le_is_monoid_le local.monoid_le_add)

  lemma not_le_minus [simp]:  "\<not> (a \<le> b) \<Longrightarrow> b - a = 0"
    by (simp add: le_is_monoid_le local.minus_def local.monoid_subtract_def)

  lemma add_diff_cancel_left [simp]: "(a + b) - a = b"
    by (simp add: minus_def)

  lemma diff_zero [simp]: "a - 0 = a"
    by (metis local.add_0_left local.add_diff_cancel_left)

  lemma diff_cancel [simp]: "a - a = 0"
    by (metis local.add_0_right local.add_diff_cancel_left)

  lemma add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
    by (simp add: local.le_is_monoid_le local.monoid_le_add_left_mono)

  lemma add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
    by (auto simp add: le_iff_add, metis add_assoc local.add_diff_cancel_left)

  lemma add_diff_cancel_left' [simp]:  "(c + a) - (c + b) = a - b"
  proof (cases "b \<le> a")
    case True thus ?thesis
      by (metis add_assoc local.add_diff_cancel_left local.le_iff_add local.monoid_le_def)
  next
    case False thus ?thesis
      using local.add_le_imp_le_left not_le_minus by blast
  qed

  lemma minus_zero_eq: "\<lbrakk> b \<le> a; a - b = 0 \<rbrakk> \<Longrightarrow> a = b"
    using local.le_iff_add local.monoid_le_def by auto

  lemma diff_add_cancel_left': "a \<le> b \<Longrightarrow> a + (b - a) = b"
    using local.le_iff_add local.monoid_le_def by auto

end

instantiation list :: (type) monoid_add
begin

  definition zero_list :: "'a list" where "zero_list = []"
  definition plus_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where "plus_list = op @"

instance
  by (intro_classes, simp_all add: zero_list_def plus_list_def)

end

lemma monoid_le_list:
  "(xs :: 'a list) \<le>\<^sub>m ys \<longleftrightarrow> xs \<le> ys"
  apply (simp add: monoid_le_def plus_list_def)
  using Prefix_Order.prefixE Prefix_Order.prefixI apply blast
done

lemma monoid_subtract_list:
  "(xs :: 'a list) -\<^sub>m ys = xs - ys"
  apply (auto simp add: monoid_subtract_def monoid_le_list minus_list_def less_eq_list_def)
  apply (rule the_equality)
  apply (simp_all add: zero_list_def plus_list_def prefix_drop)
done

instance list :: (type) ordered_cancel_monoid_diff
  apply (intro_classes, simp_all add: zero_list_def plus_list_def monoid_le_def monoid_subtract_list)
  using Prefix_Order.prefixE Prefix_Order.prefixI apply blast
  apply (simp add: less_list_def)
done

lemma monoid_le_nat:
  "(x :: nat) \<le>\<^sub>m y \<longleftrightarrow> x \<le> y"
  using ordered_cancel_comm_monoid_diff_class.le_iff_add
  by (auto simp add: monoid_le_def )

lemma monoid_subtract_nat:
  "(x :: nat) -\<^sub>m y = x - y"
  by (auto simp add: monoid_subtract_def monoid_le_nat)

instance nat :: ordered_cancel_monoid_diff
  apply (intro_classes, simp_all add: monoid_subtract_nat)
  apply (simp add: monoid_le_nat)
  apply linarith
done

end