(*  Title:      ZF/ex/Group.thy *)

section \<open>Groups\<close>

theory Group imports ZF begin

text\<open>Based on work by Clemens Ballarin, Florian Kammueller, L C Paulson and
Markus Wenzel.\<close>

subsection \<open>Monoids\<close>

(*First, we must simulate a record declaration:
record monoid =
  carrier :: i
  mult :: "[i,i] \<Rightarrow> i" (infixl "\<cdot>\<index>" 70)
  one :: i ("\<one>\<index>")
*)

definition
  carrier :: "i \<Rightarrow> i" where
  "carrier(M) \<equiv> fst(M)"

definition
  mmult :: "[i, i, i] \<Rightarrow> i" (infixl \<open>\<cdot>\<index>\<close> 70) where
  "mmult(M,x,y) \<equiv> fst(snd(M)) ` \<langle>x,y\<rangle>"

definition
  one :: "i \<Rightarrow> i" (\<open>\<one>\<index>\<close>) where
  "one(M) \<equiv> fst(snd(snd(M)))"

definition
  update_carrier :: "[i,i] \<Rightarrow> i" where
  "update_carrier(M,A) \<equiv> <A,snd(M)>"

definition
  m_inv :: "i \<Rightarrow> i \<Rightarrow> i" (\<open>inv\<index> _\<close> [81] 80) where
  "inv\<^bsub>G\<^esub> x \<equiv> (THE y. y \<in> carrier(G) \<and> y \<cdot>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> \<and> x \<cdot>\<^bsub>G\<^esub> y = \<one>\<^bsub>G\<^esub>)"

locale monoid = fixes G (structure)
  assumes m_closed [intro, simp]:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
      and m_assoc:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
          \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
      and one_closed [intro, simp]: "\<one> \<in> carrier(G)"
      and l_one [simp]: "x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
      and r_one [simp]: "x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"

text\<open>Simulating the record\<close>
lemma carrier_eq [simp]: "carrier(\<langle>A,Z\<rangle>) = A"
  by (simp add: carrier_def)

lemma mult_eq [simp]: "mmult(<A,M,Z>, x, y) = M ` \<langle>x,y\<rangle>"
  by (simp add: mmult_def)

lemma one_eq [simp]: "one(<A,M,I,Z>) = I"
  by (simp add: one_def)

lemma update_carrier_eq [simp]: "update_carrier(\<langle>A,Z\<rangle>,B) = \<langle>B,Z\<rangle>"
  by (simp add: update_carrier_def)

lemma carrier_update_carrier [simp]: "carrier(update_carrier(M,B)) = B"
  by (simp add: update_carrier_def)

lemma mult_update_carrier [simp]: "mmult(update_carrier(M,B),x,y) = mmult(M,x,y)"
  by (simp add: update_carrier_def mmult_def)

lemma one_update_carrier [simp]: "one(update_carrier(M,B)) = one(M)"
  by (simp add: update_carrier_def one_def)

lemma (in monoid) inv_unique:
  assumes eq: "y \<cdot> x = \<one>"  "x \<cdot> y' = \<one>"
    and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "y' \<in> carrier(G)"
  shows "y = y'"
proof -
  from G eq have "y = y \<cdot> (x \<cdot> y')" by simp
  also from G have "... = (y \<cdot> x) \<cdot> y'" by (simp add: m_assoc)
  also from G eq have "... = y'" by simp
  finally show ?thesis .
qed

text \<open>
  A group is a monoid all of whose elements are invertible.
\<close>

locale group = monoid +
  assumes inv_ex:
     "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"

lemma (in group) is_group [simp]: "group(G)" by (rule group_axioms)

theorem groupI:
  fixes G (structure)
  assumes m_closed [simp]:
      "\<And>x y. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
    and one_closed [simp]: "\<one> \<in> carrier(G)"
    and m_assoc:
      "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
      (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and l_one [simp]: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
    and l_inv_ex: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one>"
  shows "group(G)"
proof -
  have l_cancel [simp]:
    "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
    (x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
  proof
    fix x y z
    assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
    {
      assume eq: "x \<cdot> y = x \<cdot> z"
      with G l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
        and l_inv: "x_inv \<cdot> x = \<one>" by fast
      from G eq xG have "(x_inv \<cdot> x) \<cdot> y = (x_inv \<cdot> x) \<cdot> z"
        by (simp add: m_assoc)
      with G show "y = z" by (simp add: l_inv)
    next
      assume eq: "y = z"
      with G show "x \<cdot> y = x \<cdot> z" by simp
    }
  qed
  have r_one:
    "\<And>x. x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
      and l_inv: "x_inv \<cdot> x = \<one>" by fast
    from x xG have "x_inv \<cdot> (x \<cdot> \<one>) = x_inv \<cdot> x"
      by (simp add: m_assoc [symmetric] l_inv)
    with x xG show "x \<cdot> \<one> = x" by simp
  qed
  have inv_ex:
    "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain y where y: "y \<in> carrier(G)"
      and l_inv: "y \<cdot> x = \<one>" by fast
    from x y have "y \<cdot> (x \<cdot> y) = y \<cdot> \<one>"
      by (simp add: m_assoc [symmetric] l_inv r_one)
    with x y have r_inv: "x \<cdot> y = \<one>"
      by simp
    from x y show "\<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"
      by (fast intro: l_inv r_inv)
  qed
  show ?thesis
    by (blast intro: group.intro monoid.intro group_axioms.intro
                     assms r_one inv_ex)
qed

lemma (in group) inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G) \<and> inv x \<cdot> x = \<one> \<and> x \<cdot> inv x = \<one>"
  apply (frule inv_ex)
    unfolding Bex_def m_inv_def
  apply (erule exE)
  apply (rule theI)
  apply (rule ex1I, assumption)
   apply (blast intro: inv_unique)
  done

lemma (in group) inv_closed [intro!]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G)"
  by simp

lemma (in group) l_inv:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<cdot> x = \<one>"
  by simp

lemma (in group) r_inv:
  "x \<in> carrier(G) \<Longrightarrow> x \<cdot> inv x = \<one>"
  by simp

subsection \<open>Cancellation Laws and Basic Properties\<close>

lemma (in group) l_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
proof
  assume eq: "x \<cdot> y = x \<cdot> z"
  hence  "(inv x \<cdot> x) \<cdot> y = (inv x \<cdot> x) \<cdot> z"
    by (simp only: m_assoc inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  then show "x \<cdot> y = x \<cdot> z" by simp
qed

lemma (in group) r_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(y \<cdot> x = z \<cdot> x) \<longleftrightarrow> (y = z)"
proof
  assume eq: "y \<cdot> x = z \<cdot> x"
  then have "y \<cdot> (x \<cdot> inv x) = z \<cdot> (x \<cdot> inv x)"
    by (simp only: m_assoc [symmetric] inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  thus  "y \<cdot> x = z \<cdot> x" by simp
qed

lemma (in group) inv_comm:
  assumes "x \<cdot> y = \<one>"
      and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  shows "y \<cdot> x = \<one>"
proof -
  from G have "x \<cdot> y \<cdot> x = x \<cdot> \<one>" by (auto simp add: assms)
  with G show ?thesis by (simp del: r_one add: m_assoc)
qed

lemma (in group) inv_equality:
     "\<lbrakk>y \<cdot> x = \<one>; x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv x = y"
apply (simp add: m_inv_def)
apply (rule the_equality)
 apply (simp add: inv_comm [of y x])
apply (rule r_cancel [THEN iffD1], auto)
done

lemma (in group) inv_one [simp]:
  "inv \<one> = \<one>"
  by (auto intro: inv_equality)

lemma (in group) inv_inv [simp]: "x \<in> carrier(G) \<Longrightarrow> inv (inv x) = x"
  by (auto intro: inv_equality)

text\<open>This proof is by cancellation\<close>
lemma (in group) inv_mult_group:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv y \<cdot> inv x"
proof -
  assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  then have "inv (x \<cdot> y) \<cdot> (x \<cdot> y) = (inv y \<cdot> inv x) \<cdot> (x \<cdot> y)"
    by (simp add: m_assoc l_inv) (simp add: m_assoc [symmetric] l_inv)
  with G show ?thesis by (simp_all del: inv add: inv_closed)
qed

subsection \<open>Substructures\<close>

locale subgroup = fixes H and G (structure)
  assumes subset: "H \<subseteq> carrier(G)"
    and m_closed [intro, simp]: "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> H"
    and  one_closed [simp]: "\<one> \<in> H"
    and m_inv_closed [intro,simp]: "x \<in> H \<Longrightarrow> inv x \<in> H"

lemma (in subgroup) mem_carrier [simp]:
  "x \<in> H \<Longrightarrow> x \<in> carrier(G)"
  using subset by blast

lemma subgroup_imp_subset:
  "subgroup(H,G) \<Longrightarrow> H \<subseteq> carrier(G)"
  by (rule subgroup.subset)

lemma (in subgroup) group_axiomsI [intro]:
  assumes "group(G)"
  shows "group_axioms (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis by (force intro: group_axioms.intro l_inv r_inv)
qed

lemma (in subgroup) is_group [intro]:
  assumes "group(G)"
  shows "group (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis
  by (rule groupI) (auto intro: m_assoc l_inv mem_carrier)
qed

text \<open>
  Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
  it is closed under inverse, it contains \<open>inv x\<close>.  Since
  it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
\<close>

text \<open>
  Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
  it is closed under inverse, it contains \<open>inv x\<close>.  Since
  it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
\<close>

lemma (in group) one_in_subset:
  "\<lbrakk>H \<subseteq> carrier(G); H \<noteq> 0; \<forall>a \<in> H. inv a \<in> H; \<forall>a\<in>H. \<forall>b\<in>H. a \<cdot> b \<in> H\<rbrakk>
   \<Longrightarrow> \<one> \<in> H"
by (force simp add: l_inv)

text \<open>A characterization of subgroups: closed, non-empty subset.\<close>

declare monoid.one_closed [simp] group.inv_closed [simp]
  monoid.l_one [simp] monoid.r_one [simp] group.inv_inv [simp]

lemma subgroup_nonempty:
  "\<not> subgroup(0,G)"
  by (blast dest: subgroup.one_closed)

subsection \<open>Direct Products\<close>

definition
  DirProdGroup :: "[i,i] \<Rightarrow> i"  (infixr \<open>\<Otimes>\<close> 80) where
  "G \<Otimes> H \<equiv> <carrier(G) \<times> carrier(H),
              (\<lambda><\<langle>g,h\<rangle>, <g', h'>>
                   \<in> (carrier(G) \<times> carrier(H)) \<times> (carrier(G) \<times> carrier(H)).
                <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>),
              <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>, 0>"

lemma DirProdGroup_group:
  assumes "group(G)" and "group(H)"
  shows "group (G \<Otimes> H)"
proof -
  interpret G: group G by fact
  interpret H: group H by fact
  show ?thesis by (force intro!: groupI G.m_assoc H.m_assoc G.l_inv H.l_inv
          simp add: DirProdGroup_def)
qed

lemma carrier_DirProdGroup [simp]:
     "carrier (G \<Otimes> H) = carrier(G) \<times> carrier(H)"
  by (simp add: DirProdGroup_def)

lemma one_DirProdGroup [simp]:
     "\<one>\<^bsub>G \<Otimes> H\<^esub> = <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>"
  by (simp add: DirProdGroup_def)

lemma mult_DirProdGroup [simp]:
     "\<lbrakk>g \<in> carrier(G); h \<in> carrier(H); g' \<in> carrier(G); h' \<in> carrier(H)\<rbrakk>
      \<Longrightarrow> \<langle>g, h\<rangle> \<cdot>\<^bsub>G \<Otimes> H\<^esub> <g', h'> = <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>"
  by (simp add: DirProdGroup_def)

lemma inv_DirProdGroup [simp]:
  assumes "group(G)" and "group(H)"
  assumes g: "g \<in> carrier(G)"
      and h: "h \<in> carrier(H)"
  shows "inv \<^bsub>G \<Otimes> H\<^esub> \<langle>g, h\<rangle> = <inv\<^bsub>G\<^esub> g, inv\<^bsub>H\<^esub> h>"
  apply (rule group.inv_equality [OF DirProdGroup_group])
  apply (simp_all add: assms group.l_inv)
  done

subsection \<open>Isomorphisms\<close>

definition
  hom :: "[i,i] \<Rightarrow> i" where
  "hom(G,H) \<equiv>
    {h \<in> carrier(G) -> carrier(H).
      (\<forall>x \<in> carrier(G). \<forall>y \<in> carrier(G). h ` (x \<cdot>\<^bsub>G\<^esub> y) = (h ` x) \<cdot>\<^bsub>H\<^esub> (h ` y))}"

lemma hom_mult:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
   \<Longrightarrow> h ` (x \<cdot>\<^bsub>G\<^esub> y) = h ` x \<cdot>\<^bsub>H\<^esub> h ` y"
  by (simp add: hom_def)

lemma hom_closed:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(H)"
  by (auto simp add: hom_def)

lemma (in group) hom_compose:
     "\<lbrakk>h \<in> hom(G,H); i \<in> hom(H,I)\<rbrakk> \<Longrightarrow> i O h \<in> hom(G,I)"
by (force simp add: hom_def comp_fun)

lemma hom_is_fun:
  "h \<in> hom(G,H) \<Longrightarrow> h \<in> carrier(G) -> carrier(H)"
  by (simp add: hom_def)

subsection \<open>Isomorphisms\<close>

definition
  iso :: "[i,i] \<Rightarrow> i"  (infixr \<open>\<cong>\<close> 60) where
  "G \<cong> H \<equiv> hom(G,H) \<inter> bij(carrier(G), carrier(H))"

lemma (in group) iso_refl: "id(carrier(G)) \<in> G \<cong> G"
  by (simp add: iso_def hom_def id_type id_bij)

lemma (in group) iso_sym:
     "h \<in> G \<cong> H \<Longrightarrow> converse(h) \<in> H \<cong> G"
apply (simp add: iso_def bij_converse_bij, clarify)
apply (subgoal_tac "converse(h) \<in> carrier(H) \<rightarrow> carrier(G)")
 prefer 2 apply (simp add: bij_converse_bij bij_is_fun)
apply (auto intro: left_inverse_eq [of _ "carrier(G)" "carrier(H)"]
            simp add: hom_def bij_is_inj right_inverse_bij)
done

lemma (in group) iso_trans:
     "\<lbrakk>h \<in> G \<cong> H; i \<in> H \<cong> I\<rbrakk> \<Longrightarrow> i O h \<in> G \<cong> I"
  by (auto simp add: iso_def hom_compose comp_bij)

lemma DirProdGroup_commute_iso:
  assumes "group(G)" and "group(H)"
  shows "(\<lambda>\<langle>x,y\<rangle> \<in> carrier(G \<Otimes> H). \<langle>y,x\<rangle>) \<in> (G \<Otimes> H) \<cong> (H \<Otimes> G)"
proof -
  interpret group G by fact
  interpret group H by fact
  show ?thesis by (auto simp add: iso_def hom_def inj_def surj_def bij_def)
qed

lemma DirProdGroup_assoc_iso:
  assumes "group(G)" and "group(H)" and "group(I)"
  shows "(\<lambda><\<langle>x,y\<rangle>,z> \<in> carrier((G \<Otimes> H) \<Otimes> I). <x,\<langle>y,z\<rangle>>)
          \<in> ((G \<Otimes> H) \<Otimes> I) \<cong> (G \<Otimes> (H \<Otimes> I))"
proof -
  interpret group G by fact
  interpret group H by fact
  interpret group I by fact
  show ?thesis
    by (auto intro: lam_type simp add: iso_def hom_def inj_def surj_def bij_def)
qed

text\<open>Basis for homomorphism proofs: we assume two groups \<^term>\<open>G\<close> and
  \<^term>\<open>H\<close>, with a homomorphism \<^term>\<open>h\<close> between them\<close>
locale group_hom = G: group G + H: group H
  for G (structure) and H (structure) and h +
  assumes homh: "h \<in> hom(G,H)"
  notes hom_mult [simp] = hom_mult [OF homh]
    and hom_closed [simp] = hom_closed [OF homh]
    and hom_is_fun [simp] = hom_is_fun [OF homh]

lemma (in group_hom) one_closed [simp]:
  "h ` \<one> \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_one [simp]:
  "h ` \<one> = \<one>\<^bsub>H\<^esub>"
proof -
  have "h ` \<one> \<cdot>\<^bsub>H\<^esub> \<one>\<^bsub>H\<^esub> = (h ` \<one>) \<cdot>\<^bsub>H\<^esub> (h ` \<one>)"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: H.r_one)
qed

lemma (in group_hom) inv_closed [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) = inv\<^bsub>H\<^esub> (h ` x)"
proof -
  assume x: "x \<in> carrier(G)"
  then have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = \<one>\<^bsub>H\<^esub>"
    by (simp add: hom_mult [symmetric] G.r_inv del: hom_mult)
  also from x have "... = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)"
    by (simp add: hom_mult [symmetric] H.r_inv del: hom_mult)
  finally have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)" .
  with x show ?thesis by (simp del: H.inv)
qed

subsection \<open>Commutative Structures\<close>

text \<open>
  Naming convention: multiplicative structures that are commutative
  are called \emph{commutative}, additive structures are called
  \emph{Abelian}.
\<close>

subsection \<open>Definition\<close>

locale comm_monoid = monoid +
  assumes m_comm: "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y = y \<cdot> x"

lemma (in comm_monoid) m_lcomm:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
   x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume xyz: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
  from xyz have "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z" by (simp add: m_assoc)
  also from xyz have "... = (y \<cdot> x) \<cdot> z" by (simp add: m_comm)
  also from xyz have "... = y \<cdot> (x \<cdot> z)" by (simp add: m_assoc)
  finally show ?thesis .
qed

lemmas (in comm_monoid) m_ac = m_assoc m_comm m_lcomm

locale comm_group = comm_monoid + group

lemma (in comm_group) inv_mult:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv x \<cdot> inv y"
  by (simp add: m_ac inv_mult_group)

lemma (in group) subgroup_self: "subgroup (carrier(G),G)"
by (simp add: subgroup_def)

lemma (in group) subgroup_imp_group:
  "subgroup(H,G) \<Longrightarrow> group (update_carrier(G,H))"
by (simp add: subgroup.is_group)

lemma (in group) subgroupI:
  assumes subset: "H \<subseteq> carrier(G)" and non_empty: "H \<noteq> 0"
    and "\<And>a. a \<in> H \<Longrightarrow> inv a \<in> H"
    and "\<And>a b. \<lbrakk>a \<in> H; b \<in> H\<rbrakk> \<Longrightarrow> a \<cdot> b \<in> H"
  shows "subgroup(H,G)"
proof (simp add: subgroup_def assms)
  show "\<one> \<in> H"
    by (rule one_in_subset) (auto simp only: assms)
qed

subsection \<open>Bijections of a Set, Permutation Groups, Automorphism Groups\<close>

definition
  BijGroup :: "i\<Rightarrow>i" where
  "BijGroup(S) \<equiv>
    <bij(S,S),
     \<lambda>\<langle>g,f\<rangle> \<in> bij(S,S) \<times> bij(S,S). g O f,
     id(S), 0>"

subsection \<open>Bijections Form a Group\<close>

theorem group_BijGroup: "group(BijGroup(S))"
apply (simp add: BijGroup_def)
apply (rule groupI)
    apply (simp_all add: id_bij comp_bij comp_assoc)
 apply (simp add: id_bij bij_is_fun left_comp_id [of _ S S] fun_is_rel)
apply (blast intro: left_comp_inverse bij_is_inj bij_converse_bij)
done

subsection\<open>Automorphisms Form a Group\<close>

lemma Bij_Inv_mem: "\<lbrakk>f \<in> bij(S,S);  x \<in> S\<rbrakk> \<Longrightarrow> converse(f) ` x \<in> S"
by (blast intro: apply_funtype bij_is_fun bij_converse_bij)

lemma inv_BijGroup: "f \<in> bij(S,S) \<Longrightarrow> m_inv (BijGroup(S), f) = converse(f)"
apply (rule group.inv_equality)
apply (rule group_BijGroup)
apply (simp_all add: BijGroup_def bij_converse_bij
          left_comp_inverse [OF bij_is_inj])
done

lemma iso_is_bij: "h \<in> G \<cong> H \<Longrightarrow> h \<in> bij(carrier(G), carrier(H))"
by (simp add: iso_def)

definition
  auto :: "i\<Rightarrow>i" where
  "auto(G) \<equiv> iso(G,G)"

definition
  AutoGroup :: "i\<Rightarrow>i" where
  "AutoGroup(G) \<equiv> update_carrier(BijGroup(carrier(G)), auto(G))"

lemma (in group) id_in_auto: "id(carrier(G)) \<in> auto(G)"
  by (simp add: iso_refl auto_def)

lemma (in group) subgroup_auto:
      "subgroup (auto(G)) (BijGroup (carrier(G)))"
proof (rule subgroup.intro)
  show "auto(G) \<subseteq> carrier (BijGroup (carrier(G)))"
    by (auto simp add: auto_def BijGroup_def iso_def)
next
  fix x y
  assume "x \<in> auto(G)" "y \<in> auto(G)"
  thus "x \<cdot>\<^bsub>BijGroup (carrier(G))\<^esub> y \<in> auto(G)"
    by (auto simp add: BijGroup_def auto_def iso_def bij_is_fun
                       group.hom_compose comp_bij)
next
  show "\<one>\<^bsub>BijGroup (carrier(G))\<^esub> \<in> auto(G)" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto(G)"
  thus "inv\<^bsub>BijGroup (carrier(G))\<^esub> x \<in> auto(G)"
    by (simp add: auto_def inv_BijGroup iso_is_bij iso_sym)
qed

theorem (in group) AutoGroup: "group (AutoGroup(G))"
by (simp add: AutoGroup_def subgroup.is_group subgroup_auto group_BijGroup)

subsection\<open>Cosets and Quotient Groups\<close>

definition
  r_coset  :: "[i,i,i] \<Rightarrow> i"  (infixl \<open>#>\<index>\<close> 60) where
  "H #>\<^bsub>G\<^esub> a \<equiv> \<Union>h\<in>H. {h \<cdot>\<^bsub>G\<^esub> a}"

definition
  l_coset  :: "[i,i,i] \<Rightarrow> i"  (infixl \<open><#\<index>\<close> 60) where
  "a <#\<^bsub>G\<^esub> H \<equiv> \<Union>h\<in>H. {a \<cdot>\<^bsub>G\<^esub> h}"

definition
  RCOSETS  :: "[i,i] \<Rightarrow> i"  (\<open>rcosets\<index> _\<close> [81] 80) where
  "rcosets\<^bsub>G\<^esub> H \<equiv> \<Union>a\<in>carrier(G). {H #>\<^bsub>G\<^esub> a}"

definition
  set_mult :: "[i,i,i] \<Rightarrow> i"  (infixl \<open><#>\<index>\<close> 60) where
  "H <#>\<^bsub>G\<^esub> K \<equiv> \<Union>h\<in>H. \<Union>k\<in>K. {h \<cdot>\<^bsub>G\<^esub> k}"

definition
  SET_INV  :: "[i,i] \<Rightarrow> i"  (\<open>set'_inv\<index> _\<close> [81] 80) where
  "set_inv\<^bsub>G\<^esub> H \<equiv> \<Union>h\<in>H. {inv\<^bsub>G\<^esub> h}"

locale normal = subgroup + group +
  assumes coset_eq: "(\<forall>x \<in> carrier(G). H #> x = x <# H)"

notation
  normal  (infixl \<open>\<lhd>\<close> 60)

subsection \<open>Basic Properties of Cosets\<close>

lemma (in group) coset_mult_assoc:
     "\<lbrakk>M \<subseteq> carrier(G); g \<in> carrier(G); h \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (M #> g) #> h = M #> (g \<cdot> h)"
by (force simp add: r_coset_def m_assoc)

lemma (in group) coset_mult_one [simp]: "M \<subseteq> carrier(G) \<Longrightarrow> M #> \<one> = M"
by (force simp add: r_coset_def)

lemma (in group) solve_equation:
    "\<lbrakk>subgroup(H,G); x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<cdot> x"
apply (rule bexI [of _ "y \<cdot> (inv x)"])
apply (auto simp add: subgroup.m_closed subgroup.m_inv_closed m_assoc
                      subgroup.subset [THEN subsetD])
done

lemma (in group) repr_independence:
     "\<lbrakk>y \<in> H #> x;  x \<in> carrier(G); subgroup(H,G)\<rbrakk> \<Longrightarrow> H #> x = H #> y"
by (auto simp add: r_coset_def m_assoc [symmetric]
                   subgroup.subset [THEN subsetD]
                   subgroup.m_closed solve_equation)

lemma (in group) coset_join2:
     "\<lbrakk>x \<in> carrier(G);  subgroup(H,G);  x\<in>H\<rbrakk> \<Longrightarrow> H #> x = H"
  \<comment> \<open>Alternative proof is to put \<^term>\<open>x=\<one>\<close> in \<open>repr_independence\<close>.\<close>
by (force simp add: subgroup.m_closed r_coset_def solve_equation)

lemma (in group) r_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<subseteq> carrier(G)"
by (auto simp add: r_coset_def)

lemma (in group) rcosI:
     "\<lbrakk>h \<in> H; H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h \<cdot> x \<in> H #> x"
by (auto simp add: r_coset_def)

lemma (in group) rcosetsI:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<in> rcosets H"
by (auto simp add: RCOSETS_def)

text\<open>Really needed?\<close>
lemma (in group) transpose_inv:
     "\<lbrakk>x \<cdot> y = z;  x \<in> carrier(G);  y \<in> carrier(G);  z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (inv x) \<cdot> z = y"
by (force simp add: m_assoc [symmetric])

subsection \<open>Normal subgroups\<close>

lemma normal_imp_subgroup: "H \<lhd> G \<Longrightarrow> subgroup(H,G)"
  by (simp add: normal_def subgroup_def)

lemma (in group) normalI:
  "subgroup(H,G) \<Longrightarrow> (\<forall>x \<in> carrier(G). H #> x = x <# H) \<Longrightarrow> H \<lhd> G"
  by (simp add: normal_def normal_axioms_def)

lemma (in normal) inv_op_closed1:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> (inv x) \<cdot> h \<cdot> x \<in> H"
apply (insert coset_eq)
apply (auto simp add: l_coset_def r_coset_def)
apply (drule bspec, assumption)
apply (drule equalityD1 [THEN subsetD], blast, clarify)
apply (simp add: m_assoc)
apply (simp add: m_assoc [symmetric])
done

lemma (in normal) inv_op_closed2:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> h \<cdot> (inv x) \<in> H"
apply (subgoal_tac "inv (inv x) \<cdot> h \<cdot> (inv x) \<in> H")
apply simp
apply (blast intro: inv_op_closed1)
done

text\<open>Alternative characterization of normal subgroups\<close>
lemma (in group) normal_inv_iff:
     "(N \<lhd> G) \<longleftrightarrow>
      (subgroup(N,G) \<and> (\<forall>x \<in> carrier(G). \<forall>h \<in> N. x \<cdot> h \<cdot> (inv x) \<in> N))"
      (is "_ \<longleftrightarrow> ?rhs")
proof
  assume N: "N \<lhd> G"
  show ?rhs
    by (blast intro: N normal.inv_op_closed2 normal_imp_subgroup)
next
  assume ?rhs
  hence sg: "subgroup(N,G)"
    and closed: "\<And>x. x\<in>carrier(G) \<Longrightarrow> \<forall>h\<in>N. x \<cdot> h \<cdot> inv x \<in> N" by auto
  hence sb: "N \<subseteq> carrier(G)" by (simp add: subgroup.subset)
  show "N \<lhd> G"
  proof (intro normalI [OF sg], simp add: l_coset_def r_coset_def, clarify)
    fix x
    assume x: "x \<in> carrier(G)"
    show "(\<Union>h\<in>N. {h \<cdot> x}) = (\<Union>h\<in>N. {x \<cdot> h})"
    proof
      show "(\<Union>h\<in>N. {h \<cdot> x}) \<subseteq> (\<Union>h\<in>N. {x \<cdot> h})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "n \<cdot> x \<in> (\<Union>h\<in>N. {x \<cdot> h})"
        proof (rule UN_I)
          from closed [of "inv x"]
          show "inv x \<cdot> n \<cdot> x \<in> N" by (simp add: x n)
          show "n \<cdot> x \<in> {x \<cdot> (inv x \<cdot> n \<cdot> x)}"
            by (simp add: x n m_assoc [symmetric] sb [THEN subsetD])
        qed
      qed
    next
      show "(\<Union>h\<in>N. {x \<cdot> h}) \<subseteq> (\<Union>h\<in>N. {h \<cdot> x})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "x \<cdot> n \<in> (\<Union>h\<in>N. {h \<cdot> x})"
        proof (rule UN_I)
          show "x \<cdot> n \<cdot> inv x \<in> N" by (simp add: x n closed)
          show "x \<cdot> n \<in> {x \<cdot> n \<cdot> inv x \<cdot> x}"
            by (simp add: x n m_assoc sb [THEN subsetD])
        qed
      qed
    qed
  qed
qed

subsection\<open>More Properties of Cosets\<close>

lemma (in group) l_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> x <# H \<subseteq> carrier(G)"
by (auto simp add: l_coset_def subsetD)

lemma (in group) l_coset_swap:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> x \<in> y <# H"
proof (simp add: l_coset_def)
  assume "\<exists>h\<in>H. y = x \<cdot> h"
    and x: "x \<in> carrier(G)"
    and sb: "subgroup(H,G)"
  then obtain h' where h': "h' \<in> H \<and> x \<cdot> h' = y" by blast
  show "\<exists>h\<in>H. x = y \<cdot> h"
  proof
    show "x = y \<cdot> inv h'" using h' x sb
      by (auto simp add: m_assoc subgroup.subset [THEN subsetD])
    show "inv h' \<in> H" using h' sb
      by (auto simp add: subgroup.subset [THEN subsetD] subgroup.m_inv_closed)
  qed
qed

lemma (in group) l_coset_carrier:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> y \<in> carrier(G)"
by (auto simp add: l_coset_def m_assoc
                   subgroup.subset [THEN subsetD] subgroup.m_closed)

lemma (in group) l_repr_imp_subset:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "y <# H \<subseteq> x <# H"
proof -
  from y
  obtain h' where "h' \<in> H" "x \<cdot> h' = y" by (auto simp add: l_coset_def)
  thus ?thesis using x sb
    by (auto simp add: l_coset_def m_assoc
                       subgroup.subset [THEN subsetD] subgroup.m_closed)
qed

lemma (in group) l_repr_independence:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "x <# H = y <# H"
proof
  show "x <# H \<subseteq> y <# H"
    by (rule l_repr_imp_subset,
        (blast intro: l_coset_swap l_coset_carrier y x sb)+)
  show "y <# H \<subseteq> x <# H" by (rule l_repr_imp_subset [OF y x sb])
qed

lemma (in group) setmult_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G)\<rbrakk> \<Longrightarrow> H <#> K \<subseteq> carrier(G)"
by (auto simp add: set_mult_def subsetD)

lemma (in group) subgroup_mult_id: "subgroup(H,G) \<Longrightarrow> H <#> H = H"
apply (rule equalityI)
apply (auto simp add: subgroup.m_closed set_mult_def Sigma_def image_def)
apply (rule_tac x = x in bexI)
apply (rule bexI [of _ "\<one>"])
apply (auto simp add: subgroup.one_closed subgroup.subset [THEN subsetD])
done

subsubsection \<open>Set of inverses of an \<open>r_coset\<close>.\<close>

lemma (in normal) rcos_inv:
  assumes x:     "x \<in> carrier(G)"
  shows "set_inv (H #> x) = H #> (inv x)"
proof (simp add: r_coset_def SET_INV_def x inv_mult_group, safe intro!: equalityI)
  fix h
  assume h: "h \<in> H"
  {
    show "inv x \<cdot> inv h \<in> (\<Union>j\<in>H. {j \<cdot> inv x})"
    proof (rule UN_I)
      show "inv x \<cdot> inv h \<cdot> x \<in> H"
        by (simp add: inv_op_closed1 h x)
      show "inv x \<cdot> inv h \<in> {inv x \<cdot> inv h \<cdot> x \<cdot> inv x}"
        by (simp add: h x m_assoc)
    qed
  next
    show "h \<cdot> inv x \<in> (\<Union>j\<in>H. {inv x \<cdot> inv j})"
    proof (rule UN_I)
      show "x \<cdot> inv h \<cdot> inv x \<in> H"
        by (simp add: inv_op_closed2 h x)
      show "h \<cdot> inv x \<in> {inv x \<cdot> inv (x \<cdot> inv h \<cdot> inv x)}"
        by (simp add: h x m_assoc [symmetric] inv_mult_group)
    qed
  }
qed

subsubsection \<open>Theorems for \<open><#>\<close> with \<open>#>\<close> or \<open><#\<close>.\<close>

lemma (in group) setmult_rcos_assoc:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> H <#> (K #> x) = (H <#> K) #> x"
by (force simp add: r_coset_def set_mult_def m_assoc)

lemma (in group) rcos_assoc_lcos:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> K = H <#> (x <# K)"
by (force simp add: r_coset_def l_coset_def set_mult_def m_assoc)

lemma (in normal) rcos_mult_step1:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = (H <#> (x <# H)) #> y"
by (simp add: setmult_rcos_assoc subset
              r_coset_subset_G l_coset_subset_G rcos_assoc_lcos)

lemma (in normal) rcos_mult_step2:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (x <# H)) #> y = (H <#> (H #> x)) #> y"
by (insert coset_eq, simp add: normal_def)

lemma (in normal) rcos_mult_step3:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (H #> x)) #> y = H #> (x \<cdot> y)"
  by (simp add: setmult_rcos_assoc coset_mult_assoc
              subgroup_mult_id subset normal_axioms normal.axioms)

lemma (in normal) rcos_sum:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = H #> (x \<cdot> y)"
by (simp add: rcos_mult_step1 rcos_mult_step2 rcos_mult_step3)

lemma (in normal) rcosets_mult_eq: "M \<in> rcosets H \<Longrightarrow> H <#> M = M"
  \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
  by (auto simp add: RCOSETS_def subset
        setmult_rcos_assoc subgroup_mult_id normal_axioms normal.axioms)

subsubsection\<open>Two distinct right cosets are disjoint\<close>

definition
  r_congruent :: "[i,i] \<Rightarrow> i" (\<open>rcong\<index> _\<close> [60] 60) where
  "rcong\<^bsub>G\<^esub> H \<equiv> {\<langle>x,y\<rangle> \<in> carrier(G) * carrier(G). inv\<^bsub>G\<^esub> x \<cdot>\<^bsub>G\<^esub> y \<in> H}"

lemma (in subgroup) equiv_rcong:
   assumes "group(G)"
   shows "equiv (carrier(G), rcong H)"
proof -
  interpret group G by fact
  show ?thesis proof (simp add: equiv_def, intro conjI)
    show "rcong H \<subseteq> carrier(G) \<times> carrier(G)"
      by (auto simp add: r_congruent_def)
  next
    show "refl (carrier(G), rcong H)"
      by (auto simp add: r_congruent_def refl_def)
  next
    show "sym (rcong H)"
    proof (simp add: r_congruent_def sym_def, clarify)
      fix x y
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H"
      hence "inv (inv x \<cdot> y) \<in> H" by simp
      thus "inv y \<cdot> x \<in> H" by (simp add: inv_mult_group)
    qed
  next
    show "trans (rcong H)"
    proof (simp add: r_congruent_def trans_def, clarify)
      fix x y z
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H" and "inv y \<cdot> z \<in> H"
      hence "(inv x \<cdot> y) \<cdot> (inv y \<cdot> z) \<in> H" by simp
      hence "inv x \<cdot> (y \<cdot> inv y) \<cdot> z \<in> H" by (simp add: m_assoc del: inv)
      thus "inv x \<cdot> z \<in> H" by simp
    qed
  qed
qed

text\<open>Equivalence classes of \<open>rcong\<close> correspond to left cosets.
  Was there a mistake in the definitions? I'd have expected them to
  correspond to right cosets.\<close>
lemma (in subgroup) l_coset_eq_rcong:
  assumes "group(G)"
  assumes a: "a \<in> carrier(G)"
  shows "a <# H = (rcong H) `` {a}"
proof -
  interpret group G by fact
  show ?thesis
    by (force simp add: r_congruent_def l_coset_def m_assoc [symmetric] a
      Collect_image_eq)
qed

lemma (in group) rcos_equation:
  assumes "subgroup(H, G)"
  shows
     "\<lbrakk>ha \<cdot> a = h \<cdot> b; a \<in> carrier(G);  b \<in> carrier(G);
        h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
      \<Longrightarrow> hb \<cdot> a \<in> (\<Union>h\<in>H. {h \<cdot> b})" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (rule UN_I [of "hb \<cdot> ((inv ha) \<cdot> h)"], simp)
    apply (simp add: m_assoc transpose_inv)
    done
qed

lemma (in group) rcos_disjoint:
  assumes "subgroup(H, G)"
  shows "\<lbrakk>a \<in> rcosets H; b \<in> rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = 0" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: RCOSETS_def r_coset_def)
    apply (blast intro: rcos_equation assms sym)
    done
qed

subsection \<open>Order of a Group and Lagrange's Theorem\<close>

definition
  order :: "i \<Rightarrow> i" where
  "order(S) \<equiv> |carrier(S)|"

lemma (in group) rcos_self:
  assumes "subgroup(H, G)"
  shows "x \<in> carrier(G) \<Longrightarrow> x \<in> H #> x" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: r_coset_def)
    apply (rule_tac x="\<one>" in bexI) apply (auto)
    done
qed

lemma (in group) rcosets_part_G:
  assumes "subgroup(H, G)"
  shows "\<Union>(rcosets H) = carrier(G)"
proof -
  interpret subgroup H G by fact
  show ?thesis
    apply (rule equalityI)
    apply (force simp add: RCOSETS_def r_coset_def)
    apply (auto simp add: RCOSETS_def intro: rcos_self assms)
    done
qed

lemma (in group) cosets_finite:
     "\<lbrakk>c \<in> rcosets H;  H \<subseteq> carrier(G);  Finite (carrier(G))\<rbrakk> \<Longrightarrow> Finite(c)"
apply (auto simp add: RCOSETS_def)
apply (simp add: r_coset_subset_G [THEN subset_Finite])
done

text\<open>More general than the HOL version, which also requires \<^term>\<open>G\<close> to
      be finite.\<close>
lemma (in group) card_cosets_equal:
  assumes H:   "H \<subseteq> carrier(G)"
  shows "c \<in> rcosets H \<Longrightarrow> |c| = |H|"
proof (simp add: RCOSETS_def, clarify)
  fix a
  assume a: "a \<in> carrier(G)"
  show "|H #> a| = |H|"
  proof (rule eqpollI [THEN cardinal_cong])
    show "H #> a \<lesssim> H"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y \<in> H#>a. y \<cdot> inv a) \<in> inj(H #> a, H)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def m_assoc subsetD [OF H] a)
    qed
    show "H \<lesssim> H #> a"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y\<in> H. y \<cdot> a) \<in> inj(H, H #> a)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def  subsetD [OF H] a)
    qed
  qed
qed

lemma (in group) rcosets_subset_PowG:
     "subgroup(H,G) \<Longrightarrow> rcosets H \<subseteq> Pow(carrier(G))"
apply (simp add: RCOSETS_def)
apply (blast dest: r_coset_subset_G subgroup.subset)
done

theorem (in group) lagrange:
     "\<lbrakk>Finite(carrier(G)); subgroup(H,G)\<rbrakk>
      \<Longrightarrow> |rcosets H| #* |H| = order(G)"
apply (simp (no_asm_simp) add: order_def rcosets_part_G [symmetric])
apply (subst mult_commute)
apply (rule card_partition)
   apply (simp add: rcosets_subset_PowG [THEN subset_Finite])
  apply (simp add: rcosets_part_G)
 apply (simp add: card_cosets_equal [OF subgroup.subset])
apply (simp add: rcos_disjoint)
done

subsection \<open>Quotient Groups: Factorization of a Group\<close>

definition
  FactGroup :: "[i,i] \<Rightarrow> i" (infixl \<open>Mod\<close> 65) where
    \<comment> \<open>Actually defined for groups rather than monoids\<close>
  "G Mod H \<equiv>
     <rcosets\<^bsub>G\<^esub> H, \<lambda>\<langle>K1,K2\<rangle> \<in> (rcosets\<^bsub>G\<^esub> H) \<times> (rcosets\<^bsub>G\<^esub> H). K1 <#>\<^bsub>G\<^esub> K2, H, 0>"

lemma (in normal) setmult_closed:
     "\<lbrakk>K1 \<in> rcosets H; K2 \<in> rcosets H\<rbrakk> \<Longrightarrow> K1 <#> K2 \<in> rcosets H"
by (auto simp add: rcos_sum RCOSETS_def)

lemma (in normal) setinv_closed:
     "K \<in> rcosets H \<Longrightarrow> set_inv K \<in> rcosets H"
by (auto simp add: rcos_inv RCOSETS_def)

lemma (in normal) rcosets_assoc:
     "\<lbrakk>M1 \<in> rcosets H; M2 \<in> rcosets H; M3 \<in> rcosets H\<rbrakk>
      \<Longrightarrow> M1 <#> M2 <#> M3 = M1 <#> (M2 <#> M3)"
by (auto simp add: RCOSETS_def rcos_sum m_assoc)

lemma (in subgroup) subgroup_in_rcosets:
  assumes "group(G)"
  shows "H \<in> rcosets H"
proof -
  interpret group G by fact
  have "H #> \<one> = H"
    using _ subgroup_axioms by (rule coset_join2) simp_all
  then show ?thesis
    by (auto simp add: RCOSETS_def intro: sym)
qed

lemma (in normal) rcosets_inv_mult_group_eq:
     "M \<in> rcosets H \<Longrightarrow> set_inv M <#> M = H"
by (auto simp add: RCOSETS_def rcos_inv rcos_sum subgroup.subset normal_axioms normal.axioms)

theorem (in normal) factorgroup_is_group:
  "group (G Mod H)"
apply (simp add: FactGroup_def)
apply (rule groupI)
    apply (simp add: setmult_closed)
   apply (simp add: normal_imp_subgroup subgroup_in_rcosets)
  apply (simp add: setmult_closed rcosets_assoc)
 apply (simp add: normal_imp_subgroup
                  subgroup_in_rcosets rcosets_mult_eq)
apply (auto dest: rcosets_inv_mult_group_eq simp add: setinv_closed)
done

lemma (in normal) inv_FactGroup:
     "X \<in> carrier (G Mod H) \<Longrightarrow> inv\<^bsub>G Mod H\<^esub> X = set_inv X"
apply (rule group.inv_equality [OF factorgroup_is_group])
apply (simp_all add: FactGroup_def setinv_closed rcosets_inv_mult_group_eq)
done

text\<open>The coset map is a homomorphism from \<^term>\<open>G\<close> to the quotient group
  \<^term>\<open>G Mod H\<close>\<close>
lemma (in normal) r_coset_hom_Mod:
  "(\<lambda>a \<in> carrier(G). H #> a) \<in> hom(G, G Mod H)"
by (auto simp add: FactGroup_def RCOSETS_def hom_def rcos_sum intro: lam_type)

subsection\<open>The First Isomorphism Theorem\<close>

text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.\<close>

definition
  kernel :: "[i,i,i] \<Rightarrow> i" where
    \<comment> \<open>the kernel of a homomorphism\<close>
  "kernel(G,H,h) \<equiv> {x \<in> carrier(G). h ` x = \<one>\<^bsub>H\<^esub>}"

lemma (in group_hom) subgroup_kernel: "subgroup (kernel(G,H,h), G)"
apply (rule subgroup.intro)
apply (auto simp add: kernel_def group.intro)
done

text\<open>The kernel of a homomorphism is a normal subgroup\<close>
lemma (in group_hom) normal_kernel: "(kernel(G,H,h)) \<lhd> G"
apply (simp add: group.normal_inv_iff subgroup_kernel group.intro)
apply (simp add: kernel_def)
done

lemma (in group_hom) FactGroup_nonempty:
  assumes X: "X \<in> carrier (G Mod kernel(G,H,h))"
  shows "X \<noteq> 0"
proof -
  from X
  obtain g where "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  thus ?thesis
   by (auto simp add: kernel_def r_coset_def image_def intro: hom_one)
qed

lemma (in group_hom) FactGroup_contents_mem:
  assumes X: "X \<in> carrier (G Mod (kernel(G,H,h)))"
  shows "contents (h``X) \<in> carrier(H)"
proof -
  from X
  obtain g where g: "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence "h `` X = {h ` g}"
    by (auto simp add: kernel_def r_coset_def image_UN
                       image_eq_UN [OF hom_is_fun] g)
  thus ?thesis by (auto simp add: g)
qed

lemma mult_FactGroup:
     "\<lbrakk>X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)\<rbrakk>
      \<Longrightarrow> X \<cdot>\<^bsub>(G Mod H)\<^esub> X' = X <#>\<^bsub>G\<^esub> X'"
by (simp add: FactGroup_def)

lemma (in normal) FactGroup_m_closed:
     "\<lbrakk>X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)\<rbrakk>
      \<Longrightarrow> X <#>\<^bsub>G\<^esub> X' \<in> carrier(G Mod H)"
by (simp add: FactGroup_def setmult_closed)

lemma (in group_hom) FactGroup_hom:
     "(\<lambda>X \<in> carrier(G Mod (kernel(G,H,h))). contents (h``X))
      \<in> hom (G Mod (kernel(G,H,h)), H)"
proof (simp add: hom_def FactGroup_contents_mem lam_type mult_FactGroup normal.FactGroup_m_closed [OF normal_kernel], intro ballI)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where "g \<in> carrier(G)" and "g' \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g" and "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  hence "h `` (X <#> X') = {h ` g \<cdot>\<^bsub>H\<^esub> h ` g'}" using X X'
    by (auto dest!: FactGroup_nonempty
             simp add: set_mult_def image_eq_UN [OF hom_is_fun] image_UN
                       subsetD [OF Xsub] subsetD [OF X'sub])
  thus "contents (h `` (X <#> X')) = contents (h `` X) \<cdot>\<^bsub>H\<^esub> contents (h `` X')"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
qed

text\<open>Lemma for the following injectivity result\<close>
lemma (in group_hom) FactGroup_subset:
     "\<lbrakk>g \<in> carrier(G); g' \<in> carrier(G); h ` g = h ` g'\<rbrakk>
      \<Longrightarrow>  kernel(G,H,h) #> g \<subseteq> kernel(G,H,h) #> g'"
apply (clarsimp simp add: kernel_def r_coset_def image_def)
apply (rename_tac y)
apply (rule_tac x="y \<cdot> g \<cdot> inv g'" in bexI)
apply (simp_all add: G.m_assoc)
done

lemma (in group_hom) FactGroup_inj:
     "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
      \<in> inj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: inj_def FactGroup_contents_mem lam_type, clarify)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where gX: "g \<in> carrier(G)"  "g' \<in> carrier(G)"
              "X = kernel(G,H,h) #> g" "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  assume "contents (h `` X) = contents (h `` X')"
  hence h: "h ` g = h ` g'"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
  show "X=X'" by (rule equalityI) (simp_all add: FactGroup_subset h gX)
qed

lemma (in group_hom) kernel_rcoset_subset:
  assumes g: "g \<in> carrier(G)"
  shows "kernel(G,H,h) #> g \<subseteq> carrier (G)"
    by (auto simp add: g kernel_def r_coset_def)

text\<open>If the homomorphism \<^term>\<open>h\<close> is onto \<^term>\<open>H\<close>, then so is the
homomorphism from the quotient group\<close>
lemma (in group_hom) FactGroup_surj:
  assumes h: "h \<in> surj(carrier(G), carrier(H))"
  shows "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
         \<in> surj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: surj_def FactGroup_contents_mem lam_type, clarify)
  fix y
  assume y: "y \<in> carrier(H)"
  with h obtain g where g: "g \<in> carrier(G)" "h ` g = y"
    by (auto simp add: surj_def)
  hence "(\<Union>x\<in>kernel(G,H,h) #> g. {h ` x}) = {y}"
    by (auto simp add: y kernel_def r_coset_def)
  with g show "\<exists>x\<in>carrier(G Mod kernel(G, H, h)). contents(h `` x) = y"
        \<comment> \<open>The witness is \<^term>\<open>kernel(G,H,h) #> g\<close>\<close>
    by (force simp add: FactGroup_def RCOSETS_def
           image_eq_UN [OF hom_is_fun] kernel_rcoset_subset)
qed

text\<open>If \<^term>\<open>h\<close> is a homomorphism from \<^term>\<open>G\<close> onto \<^term>\<open>H\<close>, then the
 quotient group \<^term>\<open>G Mod (kernel(G,H,h))\<close> is isomorphic to \<^term>\<open>H\<close>.\<close>
theorem (in group_hom) FactGroup_iso:
  "h \<in> surj(carrier(G), carrier(H))
   \<Longrightarrow> (\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h``X)) \<in> (G Mod (kernel(G,H,h))) \<cong> H"
by (simp add: iso_def FactGroup_hom FactGroup_inj bij_def FactGroup_surj)

end


(*  Title:      HOL/MicroJava/DFA/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section \<open>More on Semilattices\<close>

theory SemilatAlg
imports Typing_Framework Product
begin

definition lesubstep_type :: "(nat \<times> 's) list \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) list \<Rightarrow> bool"
                    ("(_ /\<le>|_| _)" [50, 0, 51] 50) where
  "x \<le>|r| y \<equiv> \<forall>(p,s) \<in> set x. \<exists>s'. (p,s') \<in> set y \<and> s <=_r s'"

primrec plusplussub :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65) where
  "[] ++_f y = y"
| "(x#xs) ++_f y = xs ++_f (x +_f y)"

definition bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool" where
"bounded step n == !p<n. !s. !(q,t):set(step p s). q<n"

definition pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool" where
"pres_type step n A == \<forall>s\<in>A. \<forall>p<n. \<forall>(q,s')\<in>set (step p s). s' \<in> A"

definition mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool" where
"mono r step n A ==
 \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> step p s \<le>|r| step p t"

lemma pres_typeD:
  "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
  by (unfold pres_type_def, blast)

lemma monoD:
  "\<lbrakk> mono r step n A; p < n; s\<in>A; s <=_r t \<rbrakk> \<Longrightarrow> step p s \<le>|r| step p t"
  by (unfold mono_def, blast)

lemma boundedD:
  "\<lbrakk> bounded step n; p < n; (q,t) : set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
  by (unfold bounded_def, blast)

lemma lesubstep_type_refl [simp, intro]:
  "(\<And>x. x <=_r x) \<Longrightarrow> x \<le>|r| x"
  by (unfold lesubstep_type_def) auto

lemma lesub_step_typeD:
  "a \<le>|r| b \<Longrightarrow> (x,y) \<in> set a \<Longrightarrow> \<exists>y'. (x, y') \<in> set b \<and> y <=_r y'"
  by (unfold lesubstep_type_def) blast

lemma list_update_le_listI [rule_format]:
  "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x <=_r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
   xs[p := x +_f xs!p] <=[r] ys"
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done

lemma plusplus_closed: assumes "semilat (A, r, f)" shows
  "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x ++_f y \<in> A" (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" proof (induct x)
    show "\<And>y. y \<in> A \<Longrightarrow> [] ++_f y \<in> A" by simp
    fix y x xs
    assume y: "y \<in> A" and xs: "set (x#xs) \<subseteq> A"
    assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs ++_f y \<in> A"
    from xs obtain x: "x \<in> A" and xs': "set xs \<subseteq> A" by simp
    from x y have "(x +_f y) \<in> A" ..
    with xs' have "xs ++_f (x +_f y) \<in> A" by (rule IH)
    thus "(x#xs) ++_f y \<in> A" by simp
  qed
qed

lemma (in Semilat) pp_ub2:
 "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r x ++_f y"
proof (induct x)
  from semilat show "\<And>y. y <=_r [] ++_f y" by simp

  fix y a l
  assume y:  "y \<in> A"
  assume "set (a#l) \<subseteq> A"
  then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
  assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r l ++_f y"
  hence IH: "\<And>y. y \<in> A \<Longrightarrow> y <=_r l ++_f y" using x .

  from a y have "y <=_r a +_f y" ..
  also from a y have "a +_f y \<in> A" ..
  hence "(a +_f y) <=_r l ++_f (a +_f y)" by (rule IH)
  finally have "y <=_r l ++_f (a +_f y)" .
  thus "y <=_r (a#l) ++_f y" by simp
qed

  fix y s ls
  assume "set (s#ls) \<subseteq> A"
  then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
  assume y: "y \<in> A"

  assume
    "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
  hence IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x <=_r ls ++_f y" using ls .

  assume "x \<in> set (s#ls)"
  then obtain xls: "x = s \<or> x \<in> set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "s <=_r s +_f y" ..
    also from s y have "s +_f y \<in> A" ..
    with ls have "(s +_f y) <=_r ls ++_f (s +_f y)" by (rule pp_ub2)
    finally have "s <=_r ls ++_f (s +_f y)" .
    with xs have "x <=_r ls ++_f (s +_f y)" by simp
  }
  moreover {
    assume "x \<in> set ls"
    hence "\<And>y. y \<in> A \<Longrightarrow> x <=_r ls ++_f y" by (rule IH)
    moreover from s y have "s +_f y \<in> A" ..
    ultimately have "x <=_r ls ++_f (s +_f y)" .
  }
  ultimately
  have "x <=_r ls ++_f (s +_f y)" by blast
  thus "x <=_r (s#ls) ++_f y" by simp
qed

lemma (in Semilat) pp_lub:
  assumes z: "z \<in> A"
  shows
  "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x <=_r z \<Longrightarrow> y <=_r z \<Longrightarrow> xs ++_f y <=_r z"
proof (induct xs)
  fix y assume "y <=_r z" thus "[] ++_f y <=_r z" by simp
next
  fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
  then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
  assume "\<forall>x \<in> set (l#ls). x <=_r z"
  then obtain lz: "l <=_r z" and lsz: "\<forall>x \<in> set ls. x <=_r z" by auto
  assume "y <=_r z" with lz have "l +_f y <=_r z" using l y z ..
  moreover
  from l y have "l +_f y \<in> A" ..
  moreover
  assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x <=_r z \<Longrightarrow> y <=_r z
          \<Longrightarrow> ls ++_f y <=_r z"
  ultimately
  have "ls ++_f (l +_f y) <=_r z" using ls lsz by -
  thus "(l#ls) ++_f y <=_r z" by simp
qed

lemma ub1':
  assumes "semilat (A, r, f)"
  shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
  \<Longrightarrow> b <=_r map snd [(p', t')\<leftarrow>S. p' = a] ++_f y"
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)

  let "b <=_r ?map ++_f y" = ?thesis

  assume "y \<in> A"
  moreover
  assume "\<forall>(p,s) \<in> set S. s \<in> A"
  hence "set ?map \<subseteq> A" by auto
  moreover
  assume "(a,b) \<in> set S"
  hence "b \<in> set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed

lemma plusplus_empty:
  "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' +_f ss ! q = ss ! q \<Longrightarrow>
   (map snd [(p', t') \<leftarrow> S. p' = q] ++_f ss ! q) = ss ! q"
  by (induct S) auto

end


(*
  File:     Mertens_Theorems.thy
  Author:   Manuel Eberl (TU München)

*)
section \<open>Mertens' Theorems\<close>
theory Mertens_Theorems
imports
  Prime_Counting_Functions
  "Stirling_Formula.Stirling_Formula"
begin

(*<*)
unbundle prime_counting_notation
(*>*)

text \<open>
  In this section, we will prove Mertens' First and Second Theorem. These are weaker results
  than the Prime Number Theorem, and we will derive them without using it.

  However, like Mertens himself, we will not only prove them \<^emph>\<open>asymptotically\<close>, but \<^emph>\<open>absolutely\<close>.
  This means that we will show that the remainder terms are not only ``Big-O'' of some bound, but
  we will give concrete (and reasonably tight) upper and lower bounds for them that hold on the
  entire domain. This makes the proofs a bit more tedious.
\<close>

subsection \<open>Absolute Bounds for Mertens' First Theorem\<close>

text \<open>
  We have already shown the asymptotic form of Mertens' first theorem, i.\,e.\
  $\mathfrak{M}(n) = \ln n + O(1)$. We now want to obtain some absolute bounds on the $O(1)$
  remainder term using a more careful derivation than before.

  The precise bounds we will show are
  $\mathfrak {M}(n) - \ln n \in (-1-\frac{9}{\pi^2}; \ln 4] \approx (-1.9119; 1.3863]$ for
  \<open>n \<in> \<nat>\<close>.

  First, we need a simple lemma on the finiteness of exponents to consider in a sum
  of all prime powers up to a certain point:
\<close>
lemma exponents_le_finite:
  assumes "p > (1 :: nat)" "k > 0"
  shows   "finite {i. real (p ^ (k * i + l)) \<le> x}"
proof (rule finite_subset)
  show "{i. real (p ^ (k * i + l)) \<le> x} \<subseteq> {..nat \<lfloor>x\<rfloor>}"
  proof safe
    fix i assume i: "real (p ^ (k * i + l)) \<le> x"
    have "i < 2 ^ i" by (induction i) auto
    also from assms have "i \<le> k * i + l" by (cases k) auto
    hence "2 ^ i \<le> (2 ^ (k * i + l) :: nat)"
      using assms by (intro power_increasing) auto
    also have "\<dots> \<le> p ^ (k * i + l)" using assms by (intro power_mono) auto
    also have "real \<dots> \<le> x" using i by simp
    finally show "i \<le> nat \<lfloor>x\<rfloor>" by linarith
  qed
qed auto

text \<open>
  Next, we need the following bound on $\zeta'(2)$:
\<close>
lemma deriv_zeta_2_bound: "Re (deriv zeta 2) > -1"
proof -
  have "((\<lambda>x::real. ln (x + 3) * (x + 3) powr -2) has_integral (ln 3 + 1) / 3) (interior {0..})"
    using ln_powr_has_integral_at_top[of 1 0 3 "-2"]
    by (simp add: interior_real_atLeast powr_minus)
  hence "((\<lambda>x::real. ln (x + 3) * (x + 3) powr -2) has_integral (ln 3 + 1) / 3) {0..}"
    by (subst (asm) has_integral_interior) auto
  also have "?this \<longleftrightarrow> ((\<lambda>x::real. ln (x + 3) / (x + 3) ^ 2) has_integral (ln 3 + 1) / 3) {0..}"
    by (intro has_integral_cong) (auto simp: powr_minus field_simps)
  finally have int: \<dots> .
  have "exp (1 / 2 :: real) ^ 2 \<le> 2 ^ 2"
    using exp_le by (subst exp_double [symmetric]) simp_all
  hence exp_half: "exp (1 / 2 :: real) \<le> 2"
    by (rule power2_le_imp_le) auto

  have mono: "ln x / x ^ 2 \<le> ln y / y ^ 2" if "y \<ge> exp (1/2)" "x \<ge> y" for x y :: real
  proof (rule DERIV_nonpos_imp_nonincreasing[of _ _ "\<lambda>x. ln x / x ^ 2"])
    fix t assume t: "t \<ge> y" "t \<le> x"
    have "y > 0" by (rule less_le_trans[OF _ that(1)]) auto
    with t that have "ln t \<ge> ln (exp (1 / 2))"
      by (subst ln_le_cancel_iff) auto
    hence "ln t \<ge> 1 / 2" by (simp only: ln_exp)
    from t \<open>y > 0\<close> have "((\<lambda>x. ln x / x ^ 2) has_field_derivative ((1 - 2 * ln t) / t ^ 3)) (at t)"
      by (auto intro!: derivative_eq_intros simp: eval_nat_numeral field_simps)
    moreover have "(1 - 2 * ln t) / t ^ 3 \<le> 0"
      using t that \<open>y > 0\<close> \<open>ln t \<ge> 1 / 2\<close> by (intro divide_nonpos_pos) auto
    ultimately show "\<exists>f'. ((\<lambda>x. ln x / x ^ 2) has_field_derivative f') (at t) \<and> f' \<le> 0" by blast
  qed fact+

  have "fds_converges (fds_deriv fds_zeta) (2 :: complex)"
    by (intro fds_converges_deriv) auto
  hence "(\<lambda>n. of_real (-ln (real (Suc n)) / (of_nat (Suc n)) ^ 2)) sums deriv zeta 2"
    by (auto simp: fds_converges_altdef add_ac eval_fds_deriv_zeta fds_nth_deriv scaleR_conv_of_real
             simp del: of_nat_Suc)
  note * = sums_split_initial_segment[OF sums_minus[OF sums_Re[OF this]], of 3]
    have "(\<lambda>n. ln (real (n+4)) / real (n+4) ^ 2) sums (-Re (deriv zeta 2) - (ln 2 / 4 + ln 3 / 9))"
      using * by (simp add: eval_nat_numeral)
  hence "-Re (deriv zeta 2) - (ln 2 / 4 + ln 3 / 9) =
            (\<Sum>n. ln (real (Suc n) + 3) / (real (Suc n) + 3) ^ 2)"
    by (simp_all add: sums_iff algebra_simps)
  also have "\<dots> \<le> (ln 3 + 1) / 3" using int exp_half
    by (intro decreasing_sum_le_integral divide_nonneg_pos mono) (auto simp: powr_minus field_simps)
  finally have "-Re (deriv zeta 2) \<le> (16 * ln 3 + 9 * ln 2 + 12) / 36"
    by simp
  also have "ln 3 \<le> (11 / 10 :: real)"
    using ln_approx_bounds[of 3 2] by (simp add: power_numeral_reduce numeral_2_eq_2)
  hence "(16 * ln 3 + 9 * ln 2 + 12) / 36 \<le> (16 * (11 / 10) + 9 * 25 / 36 + 12) / (36 :: real)"
    using ln2_le_25_over_36 by (intro add_mono mult_left_mono divide_right_mono) auto
  also have "\<dots> < 1" by simp
  finally show ?thesis by simp
qed

text \<open>
  Using the logarithmic derivative of Euler's product formula for $\zeta(s)$ at $s = 2$
  and the bound on $\zeta'(2)$ we have just derived, we can obtain the bound
  \[\sum_{p^i \leq x, i \geq 2} \frac{\ln p}{p^i} < \frac{9}{\pi^2}\ .\]
\<close>
lemma mertens_remainder_aux_bound:
  fixes x :: real
  defines "R \<equiv> (\<Sum>(p,i) | prime p \<and> i > 1 \<and> real (p ^ i) \<le> x. ln (real p) / p ^ i)"
  shows   "R < 9 / pi\<^sup>2"
proof -
  define S' where "S' = {(p, i). prime p \<and> i > 1 \<and> real (p ^ i) \<le> x}"
  define S'' where "S'' = {(p, i). prime p \<and> i > 1 \<and> real (p ^ Suc i) \<le> x}"

  have finite_row: "finite {i. i > 1 \<and> real (p ^ (i + k)) \<le> x}" if p: "prime p" for p k
  proof (rule finite_subset)
    show "{i. i > 1 \<and> real (p ^ (i + k)) \<le> x} \<subseteq> {..nat \<lfloor>x\<rfloor>}"
    proof safe
      fix i assume i: "i > 1" "real (p ^ (i + k)) \<le> x"
      have "i < 2 ^ (i + k)" by (induction i) auto
      also from p have "\<dots> \<le> p ^ (i + k)" by (intro power_mono) (auto dest: prime_gt_1_nat)
      also have "real \<dots> \<le> x" using i by simp
      finally show "i \<le> nat \<lfloor>x\<rfloor>" by linarith
    qed
  qed auto

  have "S'' \<subseteq> S'" unfolding S''_def S'_def
  proof safe
    fix p i assume pi: "prime p" "real (p ^ Suc i) \<le> x" "i > 1"
    have "real (p ^ i) \<le> real (p ^ Suc i)"
      using pi unfolding of_nat_le_iff by (intro power_increasing) (auto dest: prime_gt_1_nat)
    also have "\<dots> \<le> x" by fact
    finally show "real (p ^ i) \<le> x" .
  qed

  have S'_alt:  "S' = (SIGMA p:{p. prime p \<and> real p \<le> x}. {i. i > 1 \<and> real (p ^ i) \<le> x})"
    unfolding S'_def
  proof safe
    fix p i assume "prime p" "real (p ^ i) \<le> x" "i > 1"
    hence "p ^ 1 \<le> p ^ i"
      by (intro power_increasing) (auto dest: prime_gt_1_nat)
    also have "real \<dots> \<le> x" by fact
    finally show "real p \<le> x" by simp
  qed

  have finite: "finite {p. prime p \<and> real p \<le> x}"
    by (rule finite_subset[OF _ finite_Nats_le_real[of x]]) (auto dest: prime_gt_0_nat)
  have "finite S'" unfolding S'_alt using finite_row[of _ 0]
    by (intro finite_SigmaI finite) auto

  have "R \<le> 3 / 2 * (\<Sum>(p, i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i))"
  proof -
    have "R = (\<Sum>y\<in>{0, 1}. \<Sum>z | z \<in> S' \<and> snd z mod 2 = y. ln (real (fst z)) / real (fst z ^ snd z))"
      using \<open>finite S'\<close> by (subst sum.group) (auto simp: case_prod_unfold R_def S'_def)
    also have "\<dots> = (\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i)) +
                    (\<Sum>(p,i) | (p, i) \<in> S' \<and> odd i. ln (real p) / real (p ^ i))"
      unfolding even_iff_mod_2_eq_zero odd_iff_mod_2_eq_one by (simp add: case_prod_unfold)
    also have "(\<Sum>(p,i) | (p, i) \<in> S' \<and> odd i. ln (real p) / real (p ^ i)) =
                 (\<Sum>(p,i) | (p, i) \<in> S'' \<and> even i. ln (real p) / real (p ^ Suc i))"
      by (intro sum.reindex_bij_witness[of _ "\<lambda>(p,i). (p, Suc i)" "\<lambda>(p,i). (p, i - 1)"])
         (auto simp: case_prod_unfold S'_def S''_def elim: oddE simp del: power_Suc)
    also have "\<dots> \<le> (\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ Suc i))"
      using \<open>S'' \<subseteq> S'\<close> unfolding case_prod_unfold
      by (intro sum_mono2 divide_nonneg_pos ln_ge_zero finite_subset[OF _ \<open>finite S'\<close>])
         (auto simp: S'_def S''_def case_prod_unfold dest: prime_gt_0_nat simp del: power_Suc)
    also have "\<dots> \<le> (\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (2 * p ^ i))"
      unfolding case_prod_unfold
      by (intro sum_mono divide_left_mono) (auto simp: S'_def dest!: prime_gt_1_nat)
    also have "\<dots> = (1 / 2) * (\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i))"
      by (subst sum_distrib_left) (auto simp: case_prod_unfold)
    also have "(\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i)) + \<dots> =
                   3 / 2 * (\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i))"
      by simp
    finally show ?thesis by simp
  qed

  also have "(\<Sum>(p,i) | (p, i) \<in> S' \<and> even i. ln (real p) / real (p ^ i)) =
               (\<Sum>p | prime p \<and> real p \<le> x. ln (real p) *
                 (\<Sum>i | i > 0 \<and> even i \<and> real (p ^ i) \<le> x. (1 / real p) ^ i))"
   unfolding sum_distrib_left
  proof (subst sum.Sigma[OF _ ballI])
    fix p assume p: "p \<in> {p. prime p \<and> real p \<le> x}"
    thus "finite {i. 0 < i \<and> even i \<and> real (p ^ i) \<le> x}"
      by (intro finite_subset[OF _ exponents_le_finite[of p 1 0 x]]) (auto dest: prime_gt_1_nat)
  qed (auto intro!: sum.cong finite_subset[OF _ finite_Nats_le_real[of x]]
            dest: prime_gt_0_nat simp: S'_alt power_divide)
  also have "\<dots> \<le> (\<Sum>p | prime p \<and> real p \<le> x. ln (real p) / (real p ^ 2 - 1))"
  proof (rule sum_mono)
    fix p assume p: "p \<in> {p. prime p \<and> real p \<le> x}"
    have "p > 1" using p by (auto dest: prime_gt_1_nat)
    have "(\<Sum>i | i > 0 \<and> even i \<and> real (p ^ i) \<le> x. (1 / real p) ^ i) =
            (\<Sum>i | real (p ^ (2 * i + 2)) \<le> x. (1 / real p) ^ (2 * i)) / real p ^ 2"
      (is "_ = ?S / _") unfolding sum_divide_distrib
      by (rule sum.reindex_bij_witness[of _ "\<lambda>i. 2 * Suc i" "\<lambda>i. (i - 2) div 2"])
         (insert \<open>p > 1\<close>, auto simp: numeral_3_eq_3 power2_eq_square power_diff
                 algebra_simps elim!: evenE)
    also have "?S = (\<Sum>i | real (p ^ (2 * i + 2)) \<le> x. (1 / real p ^ 2) ^ i)"
      by (subst power_mult) (simp_all add: algebra_simps power_divide)
    also have "\<dots> \<le> (\<Sum>i. (1 / real p ^ 2) ^ i)"
      using exponents_le_finite[of p 2 2 x] \<open>p > 1\<close>
      by (intro sum_le_suminf) (auto simp: summable_geometric_iff)
    also have "\<dots> = real p ^ 2 / (real p ^ 2 - 1)"
      using \<open>p > 1\<close> by (subst suminf_geometric) (auto simp: field_simps)
    also have "\<dots> / real p ^ 2 = 1 / (real p ^ 2 - 1)"
      using \<open>p > 1 \<close> by (simp add: divide_simps)
    finally have "(\<Sum>i | 0 < i \<and> even i \<and> real (p ^ i) \<le> x. (1 / real p) ^ i) \<le>
                     1 / (real p ^ 2 - 1)" (is "?lhs \<le> ?rhs")
      using \<open>p > 1\<close> by (simp add: divide_right_mono)
    thus "ln (real p) * ?lhs \<le> ln (real p) / (real p ^ 2 - 1)"
      using \<open>p > 1\<close> by (simp add: divide_simps)
  qed
  also have "\<dots> = (\<Sum>\<^sub>a p | prime p \<and> real p \<le> x. ln (real p) / (real p ^ 2 - 1))"
    using finite by (intro infsetsum_finite [symmetric]) auto
  also have "\<dots> \<le> (\<Sum>\<^sub>a p | prime p. ln (real p) / (real p ^ 2 - 1))"
    using eval_fds_logderiv_zeta_real[of 2] finite
    by (intro infsetsum_mono_neutral_left divide_nonneg_pos) (auto simp: dest: prime_gt_1_nat)
  also have "\<dots> = -Re (deriv zeta (of_real 2) / zeta (of_real 2))"
    by (subst eval_fds_logderiv_zeta_real) auto
  also have "\<dots> = (-Re (deriv zeta 2)) * (6 / pi\<^sup>2)"
    by (simp add: zeta_even_numeral)
  also have "\<dots> < 1 * (6 / pi\<^sup>2)"
    using deriv_zeta_2_bound by (intro mult_strict_right_mono) auto
  also have "3 / 2 * \<dots> = 9 / pi\<^sup>2" by simp
  finally show ?thesis by simp
qed

text \<open>
  We now consider the equation
  \[\ln (n!) = \sum_{k\leq n} \Lambda(k) \left\lfloor\frac{n}{k}\right\rfloor\]
  and estimate both sides in different ways. The left-hand-side can be estimated
  using Stirling's formula, and we can simplify the right-hand side to
  \[\sum_{k\leq n} \Lambda(k) \left\lfloor\frac{n}{k}\right\rfloor =
      \sum_{p^i \leq x, i \geq 1} \ln p \left\lfloor\frac{n}{p^i}\right\rfloor\]
  and then split the sum into those $p^i$ with $i = 1$ and those with $i \geq 2$.
  Applying the bound we have just shown and some more routine estimates, we obtain the
  following reasonably strong version of Mertens' First Theorem on the naturals:
  $\mathfrak M(n) - \ln(n) \in (-1-\frac{9}{\pi^2}; \ln 4]$
\<close>
theorem mertens_bound_strong:
  fixes n :: nat assumes n: "n > 0"
  shows   "\<MM> n - ln n \<in> {-1 - 9 / pi\<^sup>2<..ln 4}"
proof (cases "n \<ge> 3")
  case False
  with n consider "n = 1" | "n = 2" by force
  thus ?thesis
  proof cases
    assume [simp]: "n = 1"
    have "-1 + (-9 / pi\<^sup>2) < 0"
      by (intro add_neg_neg divide_neg_pos) auto
    thus ?thesis by simp
  next
    assume [simp]: "n = 2"
    have eq: "\<MM> n - ln n = -ln 2 / 2" by (simp add: eval_\<MM>)
    have "-1 - 9 / pi ^ 2 + ln 2 / 2 \<le> -1 - 9 / 4 ^ 2 + 25 / 36 / 2"
      using pi_less_4 ln2_le_25_over_36
      by (intro diff_mono add_mono divide_left_mono divide_right_mono power_mono) auto
    also have "\<dots> < 0" by simp
    finally have "-ln 2 / 2 > -1 - 9 / pi\<^sup>2" by simp
    moreover {
      have "-ln 2 / 2 \<le> (0::real)" by (intro divide_nonpos_pos) auto
      also have "\<dots> \<le> ln 4" by simp
      finally have "-ln 2 / 2 \<le> ln (4 :: real)" by simp
    }
    ultimately show ?thesis unfolding eq by simp
  qed

next
  case True
  hence n: "n \<ge> 3" by simp
  have finite: "finite {(p, i). prime p \<and> i \<ge> 1 \<and> p ^ i \<le> n}"
  proof (rule finite_subset)
    show "{(p, i). prime p \<and> i \<ge> 1 \<and> p ^ i \<le> n}
            \<subseteq> {..nat \<lfloor>root 1 (real n)\<rfloor>} \<times> {..nat \<lfloor>log 2 (real n)\<rfloor>}"
      using primepows_le_subset[of "real n" 1] n unfolding of_nat_le_iff by auto
  qed auto

  define r where "r = prime_sum_upto (\<lambda>p. ln (real p) * frac (real n / real p)) n"
  define R where "R = (\<Sum>(p,i) | prime p \<and> i > 1 \<and> p ^ i \<le> n. ln (real p) * real (n div (p ^ i)))"
  define R' where "R' = (\<Sum>(p,i) | prime p \<and> i > 1 \<and> p ^ i \<le> n. ln (real p) / p ^ i)"
  have [simp]: "ln (4 :: real) = 2 * ln 2"
    using ln_realpow[of 2 2] by simp
  from pi_less_4 have "ln pi \<le> ln 4" by (subst ln_le_cancel_iff) auto
  also have "\<dots> = 2 * ln 2" by simp
  also have "\<dots> \<le> 2 * (25 / 36)" by (intro mult_left_mono ln2_le_25_over_36) auto
  finally have ln_pi: "ln pi \<le> 25 / 18" by simp
  have "ln 3 \<le> ln (4::nat)" by (subst ln_le_cancel_iff) auto
  also have "\<dots> = 2 * ln 2" by simp
  also have "\<dots> \<le> 2 * (25 / 36)" by (intro mult_left_mono ln2_le_25_over_36) auto
  finally have ln_3: "ln (3::real) \<le> 25 / 18" by simp

  have "R / n = (\<Sum>(p,i) | prime p \<and> i > 1 \<and> p ^ i \<le> n. ln (real p) * (real (n div (p ^ i)) / n))"
    by (simp add: R_def sum_divide_distrib field_simps case_prod_unfold)
  also have "\<dots> \<le> (\<Sum>(p,i) | prime p \<and> i > 1 \<and> p ^ i \<le> n. ln (real p) * (1 / p ^ i))"
    unfolding R'_def case_prod_unfold using n
    by (intro sum_mono mult_left_mono) (auto simp: field_simps real_of_nat_div dest: prime_gt_0_nat)
  also have "\<dots> = R'" by (simp add: R'_def)
  also have "R' < 9 / pi\<^sup>2"
    unfolding R'_def using mertens_remainder_aux_bound[of n] by simp
  finally have "R / n < 9 / pi\<^sup>2" .
  moreover have "R \<ge> 0"
    unfolding R_def by (intro sum_nonneg mult_nonneg_nonneg) (auto dest: prime_gt_0_nat)
  ultimately have R_bounds: "R / n \<in> {0..<9 / pi\<^sup>2}" by simp

  have "ln (fact n :: real) \<le> ln (2 * pi * n) / 2 + n * ln n - n + 1 / (12 * n)"
    using ln_fact_bounds(2)[of n] n by simp
  also have "\<dots> / n - ln n = -1 + (ln 2 + ln pi) / (2 * n) + (ln n / n) / 2 + 1 / (12 * real n ^ 2)"
    using n by (simp add: power2_eq_square field_simps ln_mult)
  also have "\<dots> \<le> -1 + (ln 2 + ln pi) / (2 * 3) + (ln 3 / 3) / 2 + 1 / (12 * 3\<^sup>2)"
    using exp_le n pi_gt3
    by (intro add_mono divide_right_mono divide_left_mono mult_mono
              mult_pos_pos ln_x_over_x_mono power_mono) auto
  also have "\<dots> \<le> -1 + (25 / 36 + 25 / 18) / (2 * 3) + (25 / 18 / 3) / 2 + 1 / (12 * 3\<^sup>2)"
    using ln_pi ln2_le_25_over_36 ln_3 by (intro add_mono divide_left_mono divide_right_mono) auto
  also have "\<dots> \<le> 0" by simp
  finally have "ln n - ln (fact n) / n \<ge> 0" using n by (simp add: divide_right_mono)
  have "-ln (fact n) \<le> -ln (2 * pi * n) / 2 - n * ln n + n"
    using ln_fact_bounds(1)[of n] n by simp
  also have "ln n + \<dots> / n = -ln (2 * pi) / (2 * n) - (ln n / n) / 2 + 1"
    using n by (simp add: field_simps ln_mult)
  also have "\<dots> \<le> 0 - 0 + 1"
    using pi_gt3 n by (intro add_mono diff_mono) auto
  finally have upper: "ln n - ln (fact n) / n \<le> 1"
    using n by (simp add: divide_right_mono)
  with \<open>ln n - ln (fact n) / n \<ge> 0\<close> have fact_bounds: "ln n - ln (fact n) / n \<in> {0..1}" by simp

  have "r \<le> prime_sum_upto (\<lambda>p. ln p * 1) n"
    using less_imp_le[OF frac_lt_1] unfolding r_def \<theta>_def prime_sum_upto_def
    by (intro sum_mono mult_left_mono) (auto simp: dest: prime_gt_0_nat)
  also have "\<dots> = \<theta> n" by (simp add: \<theta>_def)
  also have "\<dots> < ln 4 * n" using n by (intro \<theta>_upper_bound) auto
  finally have "r / n < ln 4" using n by (simp add: field_simps)
  moreover have "r \<ge> 0" unfolding r_def prime_sum_upto_def
    by (intro sum_nonneg mult_nonneg_nonneg) (auto dest: prime_gt_0_nat)
  ultimately have r_bounds: "r / n \<in> {0..<ln 4}" by simp

  have "ln (fact n :: real) = sum_upto (\<lambda>k. mangoldt k * real (n div k)) (real n)"
    by (simp add: ln_fact_conv_sum_upto_mangoldt)
  also have "\<dots> = (\<Sum>(p,i) | prime p \<and> i > 0 \<and> real (p ^ i) \<le> real n.
                       ln (real p) * real (n div (p ^ i)))"
    by (intro sum_upto_primepows) (auto simp: mangoldt_non_primepow)
  also have "{(p, i). prime p \<and> i > 0 \<and> real (p ^ i) \<le> real n} =
               {(p, i). prime p \<and> i = 1 \<and> p \<le> n} \<union>
               {(p, i). prime p \<and> i > 1 \<and> (p ^ i) \<le> n}" unfolding of_nat_le_iff
    by (auto simp: not_less le_Suc_eq)
  also have "(\<Sum>(p,i)\<in>\<dots>. ln (real p) * real (n div (p ^ i))) =
               (\<Sum>(p,i) | prime p \<and> i = 1 \<and> p \<le> n. ln (real p) * real (n div (p ^ i))) + R"
    (is "_ = ?S + _")
    by (subst sum.union_disjoint) (auto intro!: finite_subset[OF _ finite] simp: R_def)
  also have "?S = prime_sum_upto (\<lambda>p. ln (real p) * real (n div p)) n"
    unfolding prime_sum_upto_def
    by (intro sum.reindex_bij_witness[of _ "\<lambda>p. (p, 1)" fst]) auto
  also have "\<dots> = prime_sum_upto (\<lambda>p. ln (real p) * real n / real p) n - r"
    unfolding r_def prime_sum_upto_def sum_subtractf[symmetric] using n
    by (intro sum.cong) (auto simp: frac_def real_of_nat_div algebra_simps)
  also have "prime_sum_upto (\<lambda>p. ln (real p) * real n / real p) n = n * \<MM> n"
    by (simp add: primes_M_def sum_distrib_left sum_distrib_right prime_sum_upto_def field_simps)
  finally have "\<MM> n - ln n = ln (fact n) / n - ln n + r / n - R / n"
    using n by (simp add: field_simps)
  hence "ln n - \<MM> n = ln n - ln (fact n) / n - r / n + R / n"
    by simp
  with fact_bounds r_bounds R_bounds show "\<MM> n - ln n \<in> {-1 - 9 / pi\<^sup>2<..ln 4}"
    by simp
qed

text \<open>
  As a simple corollary, we obtain a similar bound on the reals.
\<close>
lemma mertens_bound_real_strong:
  fixes x :: real assumes x: "x \<ge> 1"
  shows   "\<MM> x - ln x \<in> {-1 - 9 / pi ^ 2 - ln (1 + frac x / real (nat \<lfloor>x\<rfloor>)) <.. ln 4}"
proof -
  have "\<MM> x - ln x \<le> \<MM> (real (nat \<lfloor>x\<rfloor>)) - ln (real (nat \<lfloor>x\<rfloor>))"
    using assms by simp
  also have "\<dots> \<le> ln 4"
    using mertens_bound_strong[of "nat \<lfloor>x\<rfloor>"] assms by simp
  finally have "\<MM> x - ln x \<le> ln 4" .

  from assms have pos: "real_of_int \<lfloor>x\<rfloor> \<noteq> 0" by linarith
  have "frac x / real (nat \<lfloor>x\<rfloor>) \<ge> 0"
    using assms by (intro divide_nonneg_pos) auto
  moreover have "frac x / real (nat \<lfloor>x\<rfloor>) \<le> 1 / 1"
    using assms frac_lt_1[of x] by (intro frac_le) auto
  ultimately have *: "frac x / real (nat \<lfloor>x\<rfloor>) \<in> {0..1}" by auto
  have "ln x - ln (real (nat \<lfloor>x\<rfloor>)) = ln (x / real (nat \<lfloor>x\<rfloor>))"
    using assms by (subst ln_div) auto
  also have "x / real (nat \<lfloor>x\<rfloor>) = 1 + frac x / real (nat \<lfloor>x\<rfloor>)"
    using assms pos by (simp add: frac_def field_simps)
  finally have "\<MM> x - ln x > -1-9/pi^2-ln (1 + frac x / real (nat \<lfloor>x\<rfloor>))"
    using mertens_bound_strong[of "nat \<lfloor>x\<rfloor>"] x by simp
  with \<open>\<MM> x - ln x \<le> ln 4\<close> show ?thesis by simp
qed

text \<open>
  We weaken this estimate a bit to obtain nicer bounds:
\<close>
lemma mertens_bound_real':
  fixes x :: real assumes x: "x \<ge> 1"
  shows   "\<MM> x - ln x \<in> {-2<..25/18}"
proof -
  have "\<MM> x - ln x \<le> ln 4"
    using mertens_bound_real_strong[of x] x by simp
  also have "\<dots> \<le> 25 / 18"
    using ln_realpow[of 2 2] ln2_le_25_over_36 by simp
  finally have "\<MM> x - ln x \<le> 25 / 18" .

  have ln2: "ln (2 :: real) \<in> {2/3..25/36}"
    using ln_approx_bounds[of 2 1] by (simp add: eval_nat_numeral)
  have ln3: "ln (3::real) \<in> {1..10/9}"
    using ln_approx_bounds[of 3 1] by (simp add: eval_nat_numeral)
  have ln5: "ln (5::real) \<in> {4/3..76/45}"
    using ln_approx_bounds[of 5 1] by (simp add: eval_nat_numeral)
  have ln7: "ln (7::real) \<in> {3/2..15/7}"
    using ln_approx_bounds[of 7 1] by (simp add: eval_nat_numeral)
  have ln11: "ln (11::real) \<in> {5/3..290/99}"
    using ln_approx_bounds[of 11 1] by (simp add: eval_nat_numeral)

  \<comment> \<open>Choosing the lower bound -2 is somewhat arbitrary here; it is a trade-off between getting
      a reasonably tight bound and having to make lots of case distinctions. To get -2 as a lower
      bound, we have to show the cases up to \<open>x = 11\<close> by case distinction,\<close>
  have "\<MM> x - ln x > -2"
  proof (cases "x \<ge> 11")
    case False
    hence "x \<in> {1..<2} \<or> x \<in> {2..<3} \<or> x \<in> {3..<5} \<or> x \<in> {5..<7} \<or> x \<in> {7..<11}"
      using x by force
    thus ?thesis
    proof (elim disjE)
      assume x: "x \<in> {1..<2}"
      hence "ln x - \<MM> x \<le> ln 2 - 0"
        by (intro diff_mono) auto
      also have "\<dots> < 2" using ln2_le_25_over_36 by simp
      finally show ?thesis by simp
    next
      assume x: "x \<in> {2..<3}"
      hence [simp]: "\<lfloor>x\<rfloor> = 2" by (intro floor_unique) auto
      from x have "ln x - \<MM> x \<le> ln 3 - ln 2 / 2"
        by (intro diff_mono) (auto simp: eval_\<MM>)
      also have "\<dots> = ln (9 / 2) / 2" using ln_realpow[of 3 2] by (simp add: ln_div)
      also have "\<dots> < 2" using ln_approx_bounds[of "9 / 2" 1] by (simp add: eval_nat_numeral)
      finally show ?thesis by simp
    next
      assume x: "x \<in> {3..<5}"
      hence "\<MM> 3 = \<MM> x"
        unfolding primes_M_def
        by (intro prime_sum_upto_eqI'[where a' = 3 and b' = 4])
           (auto simp: nat_le_iff le_numeral_iff nat_eq_iff floor_eq_iff)
      also have "\<MM> 3 = ln 2 / 2 + ln 3 / 3"
        by (simp add: eval_\<MM> eval_nat_numeral mark_out_code)
      finally have [simp]: "\<MM> x = ln 2 / 2 + ln 3 / 3" ..
      from x have "ln x - \<MM> x \<le> ln 5 - (ln 2 / 2 + ln 3 / 3)"
        by (intro diff_mono) auto
      also have "\<dots> < 2" using ln2 ln3 ln5 by simp
      finally show ?thesis by simp
    next
      assume x: "x \<in> {5..<7}"
      hence "\<MM> 5 = \<MM> x"
        unfolding primes_M_def
        by (intro prime_sum_upto_eqI'[where a' = 5 and b' = 6])
           (auto simp: nat_le_iff le_numeral_iff nat_eq_iff floor_eq_iff)
      also have "\<MM> 5 = ln 2 / 2 + ln 3 / 3 + ln 5 / 5"
        by (simp add: eval_\<MM> eval_nat_numeral mark_out_code)
      finally have [simp]: "\<MM> x = ln 2 / 2 + ln 3 / 3 + ln 5 / 5" ..
      from x have "ln x - \<MM> x \<le> ln 7 - (ln 2 / 2 + ln 3 / 3 + ln 5 / 5)"
        by (intro diff_mono) auto
      also have "\<dots> < 2" using ln2 ln3 ln5 ln7 by simp
      finally show ?thesis by simp
    next
      assume x: "x \<in> {7..<11}"
      hence "\<MM> 7 = \<MM> x"
        unfolding primes_M_def
        by (intro prime_sum_upto_eqI'[where a' = 7 and b' = 10])
           (auto simp: nat_le_iff le_numeral_iff nat_eq_iff floor_eq_iff)
      also have "\<MM> 7 = ln 2 / 2 + ln 3 / 3 + ln 5 / 5 + ln 7 / 7"
        by (simp add: eval_\<MM> eval_nat_numeral mark_out_code)
      finally have [simp]: "\<MM> x = ln 2 / 2 + ln 3 / 3 + ln 5 / 5 + ln 7 / 7" ..
      from x have "ln x - \<MM> x \<le> ln 11 - (ln 2 / 2 + ln 3 / 3 + ln 5 / 5 + ln 7 / 7)"
        by (intro diff_mono) auto
      also have "\<dots> < 2" using ln2 ln3 ln5 ln7 ln11 by simp
      finally show ?thesis by simp
    qed
  next
    case True
    have "ln x - \<MM> x \<le> 1 + 9/pi^2 + ln (1 + frac x / real (nat \<lfloor>x\<rfloor>))"
      using mertens_bound_real_strong[of x] x by simp
    also have "1 + frac x / real (nat \<lfloor>x\<rfloor>) \<le> 1 + 1 / 11"
      using True frac_lt_1[of x] by (intro add_mono frac_le) auto
    hence "ln (1 + frac x / real (nat \<lfloor>x\<rfloor>)) \<le> ln (1 + 1 / 11)"
      using x by (subst ln_le_cancel_iff) (auto intro!: add_pos_nonneg)
    also have "\<dots> = ln (12 / 11)" by simp
    also have "\<dots> \<le> 1585 / 18216"
      using ln_approx_bounds[of "12 / 11" 1] by (simp add: eval_nat_numeral)
    also have "9 / pi ^ 2 \<le> 9 / 3.141592653588 ^ 2"
      using pi_approx by (intro divide_left_mono power_mono mult_pos_pos) auto
    also have "1 + \<dots> + 1585 / 18216 < 2"
      by (simp add: power2_eq_square)
    finally show ?thesis by simp
  qed
  with \<open>\<MM> x - ln x \<le> 25 / 18\<close> show ?thesis by simp
qed

corollary mertens_first_theorem:
  fixes x :: real assumes x: "x \<ge> 1"
  shows   "\<bar>\<MM> x - ln x\<bar> < 2"
  using mertens_bound_real'[of x] x by (simp add: abs_if)

subsection \<open>Mertens' Second Theorem\<close>

text \<open>
  Mertens' Second Theorem concerns the asymptotics of the Prime Harmonic Series, namely
  \[\sum\limits_{p \leq x} \frac{1}{p} = \ln\ln x + M + O\left(\frac{1}{\ln x}\right)\]
  where $M \approx 0.261497$ is the Meissel--Mertens constant.

  We define the constant in the following way:
\<close>
definition meissel_mertens where
  "meissel_mertens = 1 - ln (ln 2) + integral {2..} (\<lambda>t. (\<MM> t - ln t) / (t * ln t ^ 2))"

text \<open>
  We will require the value of the integral
  $\int_a^\infty \frac{t}{\ln^2 t} \textrm{d}t = \frac{1}{\ln a}$
  as an upper bound on the remainder term:
\<close>
lemma integral_one_over_x_ln_x_squared:
  assumes a: "(a::real) > 1"
  shows "set_integrable lborel {a<..} (\<lambda>t. 1 / (t * ln t ^ 2))" (is ?th1)
    and "set_lebesgue_integral lborel {a<..} (\<lambda>t. 1 / (t * ln t ^ 2)) = 1 / ln a" (is ?th2)
    and "((\<lambda>t. 1 / (t * (ln t)\<^sup>2)) has_integral 1 / ln a) {a<..}" (is ?th3)
proof -
  have cont: "isCont (\<lambda>t. 1 / (t * (ln t)\<^sup>2)) x" if "x > a" for x
    using that a by (auto intro!: continuous_intros)
  have deriv: "((\<lambda>x. -1 / ln x) has_real_derivative 1 / (x * (ln x)\<^sup>2)) (at x)" if "x > a" for x
    using that a by (auto intro!: derivative_eq_intros simp: power2_eq_square field_simps)
  have lim1: "(((\<lambda>x. - 1 / ln x) \<circ> real_of_ereal) \<longlongrightarrow> -(1 / ln a)) (at_right (ereal a))"
    unfolding ereal_tendsto_simps using a by (real_asymp simp: field_simps)
  have lim2: "(((\<lambda>x. - 1 / ln x) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_left \<infinity>)"
    unfolding ereal_tendsto_simps using a by (real_asymp simp: field_simps)

  have "set_integrable lborel (einterval a \<infinity>) (\<lambda>t. 1 / (t * ln t ^ 2))"
    by (rule interval_integral_FTC_nonneg[OF _ deriv cont _ lim1 lim2]) (use a in auto)
  thus ?th1 by simp
  have "interval_lebesgue_integral lborel (ereal a) \<infinity> (\<lambda>t. 1 / (t * ln t ^ 2)) = 0 - (-(1 / ln a))"
    by (rule interval_integral_FTC_nonneg[OF _ deriv cont _ lim1 lim2]) (use a in auto)
  thus ?th2 by (simp add: interval_integral_to_infinity_eq)

  have "((\<lambda>t. 1 / (t * ln t ^ 2)) has_integral
           set_lebesgue_integral lebesgue {a<..} (\<lambda>t. 1 / (t * ln t ^ 2))) {a<..}"
    using \<open>?th1\<close> by (intro has_integral_set_lebesgue)
                    (auto simp: set_integrable_def integrable_completion)
  also have "set_lebesgue_integral lebesgue {a<..} (\<lambda>t. 1 / (t * ln t ^ 2)) = 1 / ln a"
    using \<open>?th2\<close> unfolding set_lebesgue_integral_def by (subst integral_completion) auto
  finally show ?th3 .
qed

text \<open>
  We show that the integral in our definition of the Meissel--Mertens constant is
  well-defined and give an upper bound for its tails:
\<close>
lemma
  assumes "a > (1 :: real)"
  defines "r \<equiv> (\<lambda>t. (\<MM> t - ln t) / (t * ln t ^ 2))"
  shows integrable_meissel_mertens:  "set_integrable lborel {a<..} r"
    and meissel_mertens_integral_le: "norm (integral {a<..} r) \<le> 2 / ln a"
proof -
  have *: "((\<lambda>t. 2 * (1 / (t * ln t ^ 2))) has_integral 2 * (1 / ln a)) {a<..}"
    using assms by (intro has_integral_mult_right integral_one_over_x_ln_x_squared) auto
  show "set_integrable lborel {a<..} r" unfolding set_integrable_def
  proof (rule Bochner_Integration.integrable_bound[OF _ _ AE_I2])
    have "integrable lborel (\<lambda>t::real. indicator {a<..} t * (2 * (1 / (t * ln t ^ 2))))"
      using integrable_mult_right[of 2,
              OF integral_one_over_x_ln_x_squared(1)[of a, unfolded set_integrable_def]] assms
      by (simp add: algebra_simps)
    thus "integrable lborel (\<lambda>t::real. indicator {a<..} t *\<^sub>R (2 / (t * ln t ^ 2)))"
      by simp
    fix x :: real
    show "norm (indicat_real {a<..} x *\<^sub>R r x) \<le>
            norm (indicat_real {a<..} x *\<^sub>R (2 / (x * ln x ^ 2)))"
    proof (cases "x > a")
      case True
      thus ?thesis
      unfolding norm_scaleR norm_mult r_def norm_divide using mertens_first_theorem[of x] assms
        by (intro mult_mono frac_le divide_nonneg_pos) (auto simp: indicator_def)
    qed (auto simp: indicator_def)
  qed (auto simp: r_def)
  hence "r integrable_on {a<..}"
    by (simp add: set_borel_integral_eq_integral(1))
  hence "norm (integral {a<..} r) \<le> integral {a<..} (\<lambda>x. 2 * (1 / (x * ln x ^ 2)))"
  proof (rule integral_norm_bound_integral)
    show  "(\<lambda>x. 2 * (1 / (x * (ln x)\<^sup>2))) integrable_on {a<..}"
      using * by (simp add: has_integral_iff)
    fix x assume "x \<in> {a<..}"
    hence "norm (r x) \<le> 2 / (x * (ln x)\<^sup>2)"
      unfolding r_def norm_divide using mertens_first_theorem[of x] assms
      by (intro mult_mono frac_le divide_nonneg_pos) (auto simp: indicator_def)
    thus "norm (r x) \<le> 2* (1 / (x * ln x ^ 2))" by simp
  qed
  also have "\<dots> = 2 / ln a"
    using * by (simp add: has_integral_iff)
  finally show "norm (integral {a<..} r) \<le> 2 / ln a" .
qed

lemma integrable_on_meissel_mertens:
  assumes "A \<subseteq> {1..}" "Inf A > 1" "A \<in> sets borel"
  shows   "(\<lambda>t. (\<MM> t - ln t) / (t * ln t ^ 2)) integrable_on A"
proof -
  from assms obtain x where x: "1 < x" "x < Inf A"
    using dense by blast
  from assms have "bdd_below A" by (intro bdd_belowI[of _ 1]) auto
  hence "A \<subseteq> {Inf A..}" by (auto simp: cInf_lower)
  also have "\<dots> \<subseteq> {x<..}" using x by auto
  finally have *: "A \<subseteq> {x<..}" .
  have "set_integrable lborel A (\<lambda>t. (\<MM> t - ln t) / (t * ln t ^ 2))"
    by (rule set_integrable_subset[OF integrable_meissel_mertens[of x]]) (use x * assms in auto)
  thus ?thesis by (simp add: set_borel_integral_eq_integral(1))
qed

lemma meissel_mertens_bounds: "\<bar>meissel_mertens - 1 + ln (ln 2)\<bar> \<le> 2 / ln 2"
proof -
  have *: "{2..} - {2<..} = {2::real}" by auto
  also have "negligible \<dots>" by simp
  finally have "integral {2..} (\<lambda>t. (\<MM> t - ln t) / (t * (ln t)\<^sup>2)) =
                  integral {2<..} (\<lambda>t. (\<MM> t - ln t) / (t * (ln t)\<^sup>2))"
    by (intro sym[OF integral_subset_negligible]) auto
  also have "norm \<dots> \<le> 2 / ln 2"
    by (rule meissel_mertens_integral_le) auto
  finally show "\<bar>meissel_mertens - 1 + ln (ln 2)\<bar> \<le> 2 / ln 2"
    by (simp add: meissel_mertens_def)
qed

text \<open>
  Finally, obtaining Mertens' second theorem from the first one is nothing but a routine
  summation by parts, followed by a use of the above bound:
\<close>
theorem mertens_second_theorem:
  defines "f \<equiv> prime_sum_upto (\<lambda>p. 1 / p)"
  shows   "\<And>x. x \<ge> 2 \<Longrightarrow> \<bar>f x - ln (ln x) - meissel_mertens\<bar> \<le> 4 / ln x"
    and   "(\<lambda>x. f x - ln (ln x) - meissel_mertens) \<in> O(\<lambda>x. 1 / ln x)"
proof -
  define r where "r = (\<lambda>t. (\<MM> t - ln t) / (t * ln t ^ 2))"

  {
    fix x :: real assume x: "x > 2"
    have "((\<lambda>t. \<MM> t * (-1 / (t * ln t ^ 2))) has_integral \<MM> x * (1 / ln x) - \<MM> 2 * (1 / ln 2) -
            (\<Sum>n\<in>real -` {2<..x}. ind prime n * (ln n / real n) * (1 / ln n))) {2..x}"
      unfolding primes_M_def prime_sum_upto_altdef1 using x
      by (intro partial_summation_strong[of "{}"])
         (auto intro!: continuous_intros derivative_eq_intros simp: power2_eq_square
               simp flip: has_field_derivative_iff_has_vector_derivative)
    also have "\<MM> x * (1 / ln x) - \<MM> 2 * (1 / ln 2) -
                 (\<Sum>n\<in>real -` {2<..x}. ind prime n * (ln n / n) * (1 / ln n)) =
               \<MM> x / ln x - (\<Sum>n\<in>insert 2 (real -` {2<..x}). ind prime n * (ln n / n) * (1 / ln n))"
      (is "_ = _ - ?S")
      by (subst sum.insert)
         (auto simp: primes_M_def finite_vimage_real_of_nat_greaterThanAtMost eval_prime_sum_upto)
    also have "?S = f x"
      unfolding f_def prime_sum_upto_altdef1 sum_upto_def using x
      by (intro sum.mono_neutral_cong_left) (auto simp: not_less numeral_2_eq_2 le_Suc_eq)
    finally have "((\<lambda>t. -\<MM> t / (t * ln t ^ 2)) has_integral (\<MM> x / ln x - f x)) {2..x}"
      by simp
    from has_integral_neg[OF this]
      have "((\<lambda>t. \<MM> t / (t * ln t ^ 2)) has_integral (f x - \<MM> x / ln x)) {2..x}" by simp
    hence "((\<lambda>t. \<MM> t / (t * ln t ^ 2) - 1 / (t * ln t)) has_integral
             (f x - \<MM> x / ln x - (ln (ln x) - ln (ln 2)))) {2..x}" using x
      by (intro has_integral_diff fundamental_theorem_of_calculus)
         (auto simp flip: has_field_derivative_iff_has_vector_derivative
               intro!: derivative_eq_intros)
    also have "?this \<longleftrightarrow> (r has_integral (f x - \<MM> x / ln x - (ln (ln x) - ln (ln 2)))) {2..x}"
      by (intro has_integral_cong) (auto simp: r_def field_simps power2_eq_square)
    finally have \<dots> .
  } note integral = this

  define R\<^sub>\<MM> where "R\<^sub>\<MM> = (\<lambda>x. \<MM> x - ln x)"
  have \<MM>: "\<MM> x = ln x + R\<^sub>\<MM> x" for x by (simp add: R\<^sub>\<MM>_def)
  define I where "I = (\<lambda>x. integral {x..} r)"
  define C where "C = (1 - ln (ln 2) + I 2)"
  have C_altdef: "C = meissel_mertens"
    by (simp add: I_def r_def C_def meissel_mertens_def)

  show bound: " \<bar>f x - ln (ln x) - meissel_mertens\<bar> \<le> 4 / ln x" if x: "x \<ge> 2" for x
  proof (cases "x = 2")
    case True
    hence "\<bar>f x - ln (ln x) - meissel_mertens\<bar> = \<bar>1 / 2 - ln (ln 2) - meissel_mertens\<bar>"
      by (simp add: f_def eval_prime_sum_upto )
    also have "\<dots> \<le> 2 / ln 2 + 1 / 2"
      using meissel_mertens_bounds by linarith
    also have "\<dots> \<le> 2 / ln 2 + 2 / ln 2" using ln2_le_25_over_36
      by (intro add_mono divide_left_mono) auto
    finally show ?thesis using True by simp
  next
    case False
    hence x: "x > 2" using x by simp
    have "integral {2..x} r + I x = integral ({2..x} \<union> {x..}) r" unfolding I_def r_def using x
      by (intro integral_Un [symmetric] integrable_on_meissel_mertens) (auto simp: max_def r_def)
    also have "{2..x} \<union> {x..} = {2..}" using x by auto
    finally have *: "integral {2..x} r = I 2 - I x" unfolding I_def by simp
    have eq: "f x - ln (ln x) - C = R\<^sub>\<MM> x / ln x - I x"
      using integral[OF x] x by (auto simp: C_def field_simps \<MM> has_integral_iff *)
    also have "\<bar>\<dots>\<bar> \<le> \<bar>R\<^sub>\<MM> x / ln x\<bar> + norm (I x)"
      unfolding real_norm_def by (rule abs_triangle_ineq4)
    also have "\<bar>R\<^sub>\<MM> x / ln x\<bar> \<le> 2 / \<bar>ln x\<bar>"
      unfolding R\<^sub>\<MM>_def abs_divide using mertens_first_theorem[of x] x
      by (intro divide_right_mono) auto
    also have "{x..} - {x<..} = {x}" and "{x<..} \<subseteq> {x..}" by auto
    hence "I x = integral {x<..} r" unfolding I_def
      by (intro integral_subset_negligible [symmetric]) simp_all
    also have "norm \<dots> \<le> 2 / ln x"
      using meissel_mertens_integral_le[of x] x by (simp add: r_def)
    finally show "\<bar>f x - ln (ln x) - meissel_mertens\<bar> \<le> 4 / ln x"
      using x by (simp add: C_altdef)
  qed

  have "(\<lambda>x. f x - ln (ln x) - C) \<in> O(\<lambda>x. 1 / ln x)"
  proof (intro landau_o.bigI[of 4] eventually_mono[OF eventually_ge_at_top[of 2]])
    fix x :: real assume x: "x \<ge> 2"
    with bound[OF x] show "norm (f x - ln (ln x) - C) \<le> 4 * norm (1 / ln x)"
      by (simp add: C_altdef)
  qed (auto intro!: add_pos_nonneg)
  thus "(\<lambda>x. f x - ln (ln x) - meissel_mertens) \<in> O(\<lambda>x. 1 / ln x)"
    by (simp add: C_altdef)
qed

corollary prime_harmonic_asymp_equiv: "prime_sum_upto (\<lambda>p. 1 / p) \<sim>[at_top] (\<lambda>x. ln (ln x))"
proof -
  define f where "f = prime_sum_upto (\<lambda>p. 1 / p)"
  have "(\<lambda>x. f x - ln (ln x) - meissel_mertens + meissel_mertens) \<in> o(\<lambda>x. ln (ln x))"
    unfolding f_def
    by (rule sum_in_smallo[OF landau_o.big_small_trans[OF mertens_second_theorem(2)]]) real_asymp+
  hence "(\<lambda>x. f x - ln (ln x)) \<in> o(\<lambda>x. ln (ln x))"
    by simp
  thus ?thesis unfolding f_def
    by (rule smallo_imp_asymp_equiv)
qed

text \<open>
  As a corollary, we get the divergence of the prime harmonic series.
\<close>
corollary prime_harmonic_diverges: "filterlim (prime_sum_upto (\<lambda>p. 1 / p)) at_top at_top"
  using asymp_equiv_symI[OF prime_harmonic_asymp_equiv]
  by (rule asymp_equiv_at_top_transfer) real_asymp

(*<*)
unbundle no_prime_counting_notation
(*>*)

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_StoogeSortPermutes
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort xs) xs"
  oops

end


(*
   Author: Mike Stannett
   Date: 27 April 2016
   m.stannett@sheffield.ac.uk
*)
theory SomeFunc
  imports Main
begin

fun  someFunc :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b"  where
    "someFunc P x = (SOME y. (P x y))"

lemma lemSomeFunc:
  assumes "\<exists>y . P x y"
     and  "f = someFunc P"
  shows   "P x (f x)"
proof -
  have "f x = (SOME y. (P x y))"
    using assms(2) by simp
  thus ?thesis using assms(1)
    by (simp add: someI_ex)
qed

end