theory Isar_Demo
imports Complex_Main
begin

section{* An introductory example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

text{* A bit shorter: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from 1 show "False" by blast
qed

subsection{* this, then, hence and thus *}

text{* Avoid labels, use this: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text{* then = from this *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  then have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then show "False" by blast
qed

text{* hence = then have, thus = then show *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

subsection{* Structured statements: fixes, assumes, shows *}

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -  --"no automatic proof step!"
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

section{* Proof patterns *}

thm iffI

lemma "P \<longleftrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
next
  assume "Q"
  show "P" sorry
qed

thm equalityI

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" sorry
next
  show "B \<subseteq> A" sorry
qed

thm subsetI

lemma "A \<subseteq> B"
proof
  fix a
  assume "a \<in> A"
  show "a \<in> B" sorry
qed

(* Sometimes, you want to combine equalityI and subsetI *)
lemma "A = (B::'a set)"
proof (intro equalityI subsetI)
  fix x assume "x\<in>A" show "x\<in>B" sorry
next
  fix x assume "x\<in>B" show "x\<in>A" sorry
qed

lemma "{x. \<exists>y. x=y+y} = {x::nat. even x}"
proof (intro equalityI subsetI)
  fix x::nat assume "x\<in>{x. \<exists>y. x=y+y}"
  hence "\<exists>y. x=y+y" by simp
  thus "x\<in>{x. even x}" by auto
next
  fix x::nat assume "x\<in>{x. even x}" thus "x\<in>{x. \<exists>y. x=y+y}" sorry
qed

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" proof
    fix x assume "x \<in> A" show "x\<in>B" sorry
  qed
next
  show "B \<subseteq> A" proof
    fix x assume "x \<in> B" show "x\<in>A" sorry
  qed
qed

text{* Contradiction *}

lemma P
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

text{* Case distinction *}

lemma "R"
proof cases
  assume "P"
  show "R" sorry
next
  assume "\<not> P"
  show "R" sorry
qed

lemma "R"
proof (cases "P::bool")
  assume "P"
  show "R" sorry
next
  assume "\<not> P"
  show "R" sorry
qed

lemma "R"
proof -
  have "P \<or> Q" sorry
  then show "R"
  proof
    assume "P"
    show "R" sorry
  next
    assume "Q"
    show "R" sorry
  qed
qed

text \<open>\<open>\<forall>\<close> introduction\<close>

lemma "\<forall>x. x < Suc x"
proof
  fix x
  show "x<Suc x" by simp
qed

text \<open>\<open>\<exists>\<close> elimination\<close>

lemma "\<exists>x. Suc x < 3"
proof
  show "Suc 0 < 3" by simp
qed

text{* obtain example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

text{* Interactive exercise: *}

lemma assumes A: "\<exists>x. \<forall>y. P x y" shows "\<forall>y. \<exists>x. P x y"
proof
  fix y
  show "\<exists>x. P x y"
  proof -
    from A obtain x where "\<forall>y. P x y" by blast
    hence "P x y" by blast
    thus "\<exists>x. P x y" by blast
  qed
qed

lemma assumes A: "\<exists>x. \<forall>y. P x y" shows "\<forall>y. \<exists>x. P x y"
proof
  fix y
  from A obtain x where 1: "P x y" by blast
  show "\<exists>x. P x y" proof
    show "P x y" by fact
  qed
qed

(* Witness for existential can only contain variables that were
  fixed BEFORE exI rule was applied!

  Try starting proof above with
    proof (intro allI exI)

*)

section{* Streamlining proofs *}

subsection{* Pattern matching and ?-variables *}

text{* Show EX *}

lemma "\<exists> xs. length xs = 0" (is "\<exists> xs. ?P xs")
proof
  show "?P []" by simp
qed

text{* Multiple EX *}

lemma "\<exists> x y :: int. x < z & z < y" (is "\<exists> x y. ?P x y")
proof (intro exI)
  show "?P (z - 1) (z + 1)" by arith
qed

(* Forward proof *)
lemma "\<exists> x y :: int. x < z & z < y" (is "\<exists> x y. ?P x y")
proof -
  have "?P (z - 1) (z + 1)" by arith
  thus ?thesis by blast
qed

subsection{* Quoting facts: *}

lemma assumes "x < (0::int)" shows "x*x > 0"
proof -
  thm \<open>x<0\<close>
  from `x<0` show ?thesis by(metis mult_neg_neg)
qed

subsection {* Example: Top Down Proof Development *}

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or>
  (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "even (length xs)"
  then obtain n where A: "length xs = n+n"
    by (metis dvdE mult_2)
  hence W1: "xs = take n xs @ drop n xs" by simp
  have W2: "length (take n xs) = length (drop n xs)" by (simp add: A)
  from W1 W2 show ?thesis by blast
next
  assume "odd (length xs)" thus ?thesis sorry
qed

subsection {* moreover *}

lemma assumes "A \<and> B" shows "B \<and> A"
proof -
  from `A \<and> B` have "A" by auto
  moreover
  from `A \<and> B` have "B" by auto
  ultimately show "B \<and> A" by auto
qed

subsection{* Raw proof blocks *}

lemma fixes k :: int assumes "k dvd (n+k)" shows "k dvd n"
proof -
  { fix a assume a: "n+k = k*a"
    have "EX b. n = k*b"
    proof
      show "n = k*(a - 1)" using a by(simp add: algebra_simps)
    qed }
  with assms show ?thesis by (auto simp add: dvd_def)
qed

subsection{* Local Lemmas. Shortcut for raw proof block with name *}

lemma fixes k :: int assumes "k dvd (n+k)" shows "k dvd n"
proof -
  have AUX: "EX b. n = k*b" if a: "n+k = k*a" for a
  proof
    show "n = k*(a - 1)" using a by(simp add: algebra_simps)
  qed
  with assms show ?thesis by (auto simp add: dvd_def)

  thm AUX (* Local lemma also available by its name *)
qed

section{* Solutions to interactive exercises *}

lemma assumes "\<exists>x. \<forall>y. P x y" shows "\<forall>y. \<exists>x. P x y"
proof
  fix b
  from assms obtain a where 0: "\<forall>y. P a y" by blast
  show "\<exists>x. P x b"
  proof
    show "P a b" using 0 by blast
  qed
qed

lemma fixes x y :: real assumes "x \<ge> y" "y > 0"
shows "(x - y) ^ 2 \<le> x^2 - y^2"
proof -
  have "(x - y) ^ 2 = x^2 + y^2 - 2*x*y"
    by(simp add: numeral_eq_Suc algebra_simps)
  also have "\<dots> \<le> x^2 + y^2 - 2*y*y"
    using assms by(simp)
  also have "\<dots> = x^2 - y^2"
    by(simp add: numeral_eq_Suc)
  finally show ?thesis .
qed

subsection {* Example: Top Down Proof Development *}

text{* The key idea: case distinction on length: *}

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or>
  (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  show ?thesis sorry
next
  assume "\<not> (EX n. length xs = n+n)"
  show ?thesis sorry
qed

text{* A proof skeleton: *}

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or>
  (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "\<exists>n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" sorry
  thus ?thesis by blast
next
  assume "\<not> (\<exists>n. length xs = n+n)"
  then obtain n where "length xs = Suc(n+n)" sorry
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" sorry
  then show ?thesis by blast
qed

text{* The complete proof: *}

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or>
  (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "\<exists>n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs"
    by (simp add: `length xs = n + n`)
  thus ?thesis by blast
next
  assume "\<not> (\<exists>n. length xs = n+n)"
  hence "\<exists>n. length xs = Suc(n+n)" by arith
  then obtain n where l: "length xs = Suc(n+n)" by blast
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by (simp add: l)
  thus ?thesis by blast
qed

end


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

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

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

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

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

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

theorem property0 :
  "((hsort2 xs) = (isort xs))"
  oops

end


theory T18
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(*
    File:      Arithmetic_Summatory_Asymptotics.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>Asymptotics of summatory arithmetic functions\<close>
theory Arithmetic_Summatory_Asymptotics
  imports
    Euler_MacLaurin.Euler_MacLaurin_Landau
    Arithmetic_Summatory
    Dirichlet_Series_Analysis
    Landau_Symbols.Landau_More
begin

subsection \<open>Auxiliary bounds\<close>

lemma sum_inverse_squares_tail_bound:
  assumes "d > 0"
  shows   "summable (\<lambda>n. 1 / (real (Suc n) + d) ^ 2)"
          "(\<Sum>n. 1 / (real (Suc n) + d) ^ 2) \<le> 1 / d"
proof -
  show *: "summable (\<lambda>n. 1 / (real (Suc n) + d) ^ 2)"
  proof (rule summable_comparison_test, intro allI exI impI)
    fix n :: nat
    from assms show "norm (1 / (real (Suc n) + d) ^ 2) \<le> 1 / real (Suc n) ^ 2"
      unfolding norm_divide norm_one norm_power
      by (intro divide_left_mono power_mono) simp_all
  qed (insert inverse_squares_sums, simp add: sums_iff)
  show "(\<Sum>n. 1 / (real (Suc n) + d) ^ 2) \<le> 1 / d"
  proof (rule sums_le[OF allI])
    fix n have "1 / (real (Suc n) + d) ^ 2 \<le> 1 / ((real n + d) * (real (Suc n) + d))"
      unfolding power2_eq_square using assms
      by (intro divide_left_mono mult_mono mult_pos_pos add_nonneg_pos) simp_all
    also have "\<dots> = 1 / (real n + d) - 1 / (real (Suc n) + d)"
      using assms by (simp add: divide_simps)
    finally show "1 / (real (Suc n) + d)\<^sup>2 \<le> 1 / (real n + d) - 1 / (real (Suc n) + d)" .
  next
    show "(\<lambda>n. 1 / (real (Suc n) + d)\<^sup>2) sums (\<Sum>n. 1 / (real (Suc n) + d)\<^sup>2)"
      using * by (simp add: sums_iff)
  next
    have "(\<lambda>n. 1 / (real n + d) - 1 / (real (Suc n) + d)) sums (1 / (real 0 + d) - 0)"
      by (intro telescope_sums' real_tendsto_divide_at_top[OF tendsto_const],
          subst add.commute, rule filterlim_tendsto_add_at_top[OF tendsto_const
            filterlim_real_sequentially])
    thus "(\<lambda>n. 1 / (real n + d) - 1 / (real (Suc n) + d)) sums (1 / d)" by simp
  qed
qed

lemma moebius_sum_tail_bound:
  assumes "d > 0"
  shows   "abs (\<Sum>n. moebius_mu (Suc n + d) / real (Suc n + d)^2) \<le> 1 / d" (is "abs ?S \<le> _")
proof -
  have *: "summable (\<lambda>n. 1 / (real (Suc n + d))\<^sup>2)"
    by (insert sum_inverse_squares_tail_bound(1)[of "real d"] assms, simp_all add: add_ac)
  have **: "summable (\<lambda>n. abs (moebius_mu (Suc n + d) / real (Suc n + d)^2))"
  proof (rule summable_comparison_test, intro exI allI impI)
    fix n :: nat
    show "norm (\<bar>moebius_mu (Suc n + d) / (real (Suc n + d))^2\<bar>) \<le>
            1 / (real (Suc n + d))^2"
      unfolding real_norm_def abs_abs abs_divide power_abs abs_of_nat
      by (intro divide_right_mono abs_moebius_mu_le) simp_all
  qed (insert *)
  from ** have "abs ?S \<le> (\<Sum>n. abs (moebius_mu (Suc n + d) / real (Suc n + d)^2))"
    by (rule summable_rabs)
  also have "\<dots> \<le> (\<Sum>n. 1 / (real (Suc n) + d) ^ 2)"
  proof (intro suminf_le allI)
    fix n :: nat
    show "abs (moebius_mu (Suc n + d) / (real (Suc n + d))^2) \<le> 1 / (real (Suc n) + real d)^2"
      unfolding abs_divide abs_of_nat power_abs of_nat_add [symmetric]
      by (intro divide_right_mono abs_moebius_mu_le) simp_all
  qed (insert * **, simp_all add: add_ac)
  also from assms have "\<dots> \<le> 1 / d" by (intro sum_inverse_squares_tail_bound) simp_all
  finally show ?thesis .
qed

lemma sum_upto_inverse_bound:
  "sum_upto (\<lambda>i. 1 / real i) x \<ge> 0"
  "eventually (\<lambda>x. sum_upto (\<lambda>i. 1 / real i) x \<le> ln x + 13 / 22) at_top"
proof -
  show "sum_upto (\<lambda>i. 1 / real i) x \<ge> 0"
    by (simp add: sum_upto_def sum_nonneg)
  from order_tendstoD(2)[OF euler_mascheroni_LIMSEQ euler_mascheroni_less_13_over_22]
  obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> harm n - ln (real n) < 13 / 22"
    unfolding eventually_at_top_linorder by blast
  show "eventually (\<lambda>x. sum_upto (\<lambda>i. 1 / real i) x \<le> ln x + 13 / 22) at_top"
    using eventually_ge_at_top[of "max (real N) 1"]
  proof eventually_elim
    case (elim x)
    have "sum_upto (\<lambda>i. 1 / real i) x = (\<Sum>i\<in>{0<..nat \<lfloor>x\<rfloor>}. 1 / real i)"
      by (simp add: sum_upto_altdef)
    also have "\<dots> = harm (nat \<lfloor>x\<rfloor>)"
      unfolding harm_def by (intro sum.cong refl) (auto simp: field_simps)
    also have "\<dots> \<le> ln (real (nat \<lfloor>x\<rfloor>)) + 13 / 22"
      using N[of "nat \<lfloor>x\<rfloor>"] elim by (auto simp: le_nat_iff le_floor_iff)
    also have "ln (real (nat \<lfloor>x\<rfloor>)) \<le> ln x" using elim by (subst ln_le_cancel_iff) auto
    finally show ?case by - simp
  qed
qed

lemma sum_upto_inverse_bigo: "sum_upto (\<lambda>i. 1 / real i) \<in> O(\<lambda>x. ln x)"
proof -
  have "eventually (\<lambda>x. norm (sum_upto (\<lambda>i. 1 / real i) x) \<le> 1 * norm (ln x + 13/22)) at_top"
    using eventually_ge_at_top[of "1::real"] sum_upto_inverse_bound(2)
    by eventually_elim (insert sum_upto_inverse_bound(1), simp_all)
  hence "sum_upto (\<lambda>i. 1 / real i) \<in> O(\<lambda>x. ln x + 13/22)"
    by (rule bigoI)
  also have "(\<lambda>x::real. ln x + 13/22) \<in> O(\<lambda>x. ln x)" by simp
  finally show ?thesis .
qed

lemma
  defines "G \<equiv> (\<lambda>x::real. (\<Sum>n. moebius_mu (n + Suc (nat \<lfloor>x\<rfloor>)) / (n + Suc (nat \<lfloor>x\<rfloor>))^2) :: real)"
  shows   moebius_sum_tail_bound': "\<And>t. t \<ge> 2 \<Longrightarrow> \<bar>G t\<bar> \<le> 1 / (t - 1)"
    and   moebius_sum_tail_bigo:   "G \<in> O(\<lambda>t. 1 / t)"
proof -
  show "\<bar>G t\<bar> \<le> 1 / (t - 1)" if t: "t \<ge> 2" for t
  proof -
    from t have "\<bar>G t\<bar> \<le> 1 / real (nat \<lfloor>t\<rfloor>)"
      unfolding G_def using moebius_sum_tail_bound[of "nat \<lfloor>t\<rfloor>"] by simp
    also have "t \<le> 1 + real_of_int \<lfloor>t\<rfloor>" by linarith
    hence "1 / real (nat \<lfloor>t\<rfloor>) \<le> 1 / (t - 1)" using t by (simp add: field_simps)
    finally show ?thesis .
  qed
  hence "G \<in> O(\<lambda>t. 1 / (t - 1))"
    by (intro bigoI[of _ 1] eventually_mono[OF eventually_ge_at_top[of "2::real"]]) auto
  also have "(\<lambda>t::real. 1 / (t - 1)) \<in> \<Theta>(\<lambda>t. 1 / t)" by simp
  finally show "G \<in> O(\<lambda>t. 1 / t)" .
qed

subsection \<open>Summatory totient function\<close>

theorem summatory_totient_asymptotics':
  "(\<lambda>x. sum_upto (\<lambda>n. real (totient n)) x) =o (\<lambda>x. 3 / pi\<^sup>2 * x\<^sup>2) +o O(\<lambda>x. x * ln x)"
  using summatory_totient_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem summatory_totient_asymptotics'':
  "sum_upto (\<lambda>n. real (totient n)) \<sim>[at_top] (\<lambda>x. 3 / pi\<^sup>2 * x\<^sup>2)"
proof -
  have "(\<lambda>x. sum_upto (\<lambda>n. real (totient n)) x - 3 / pi\<^sup>2 * x\<^sup>2) \<in> O(\<lambda>x. x * ln x)"
    by (rule summatory_totient_asymptotics)
  also have "(\<lambda>x. x * ln x) \<in> o(\<lambda>x. 3 / pi ^ 2 * x ^ 2)" by simp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

subsection \<open>Asymptotic distribution of squarefree numbers\<close>

lemma le_sqrt_iff: "x \<ge> 0 \<Longrightarrow> x \<le> sqrt y \<longleftrightarrow> x^2 \<le> y"
  using real_sqrt_le_iff[of "x^2" y] by (simp del: real_sqrt_le_iff)

theorem squarefree_asymptotics: "(\<lambda>x. card {n. real n \<le> x \<and> squarefree n} - 6 / pi\<^sup>2 * x) \<in> O(sqrt)"
proof -
  define f :: "nat \<Rightarrow> real" where "f = (\<lambda>n. if n = 0 then 0 else 1)"
  define g :: "nat \<Rightarrow> real" where "g = dirichlet_prod (ind squarefree) moebius_mu"

  interpret g: multiplicative_function g unfolding g_def
    by (intro multiplicative_dirichlet_prod squarefree.multiplicative_function_axioms
              moebius_mu.multiplicative_function_axioms)
  interpret g: multiplicative_function' g "\<lambda>p k. if k = 2 then -1 else 0" "\<lambda>_. 0"
  proof
    interpret g': multiplicative_dirichlet_prod' "ind squarefree" moebius_mu
     "\<lambda>p k. if 1 < k then 0 else 1" "\<lambda>p k. if k = 1 then - 1 else 0" "\<lambda>_. 1" "\<lambda>_. - 1"
    by (intro multiplicative_dirichlet_prod'.intro squarefree.multiplicative_function'_axioms
              moebius_mu.multiplicative_function'_axioms)
    fix p k :: nat assume "prime p" "k > 0"
    hence "g (p ^ k) = (\<Sum>i\<in>{0<..<k}. (if Suc 0 < i then 0 else 1) *
                           (if k - i = Suc 0 then - 1 else 0))"
      by (auto simp: g'.prime_power g_def)
    also have "\<dots> = (\<Sum>i\<in>{0<..<k}. (if k = 2 then -1 else 0))"
      by (intro sum.cong refl) auto
    also from \<open>k > 0\<close> have "\<dots> = (if k = 2 then -1 else 0)" by simp
    finally show "g (p ^ k) = \<dots>" .
  qed simp_all
  have mult_g_square: "multiplicative_function (\<lambda>n. g (n ^ 2))"
    by standard (simp_all add: power_mult_distrib g.mult_coprime)

  have g_square: "g (m ^ 2) = moebius_mu m" for m
    using mult_g_square moebius_mu.multiplicative_function_axioms
  proof (rule multiplicative_function_eqI)
    fix p k :: nat assume *: "prime p" "k > 0"
    have "g ((p ^ k) ^ 2) = g (p ^ (2 * k))" by (simp add: power_mult [symmetric] mult_ac)
    also from * have "\<dots> = (if k = 1 then -1 else 0)" by (simp add: g.prime_power)
    also from * have "\<dots> = moebius_mu (p ^ k)" by (simp add: moebius_mu.prime_power)
    finally show "g ((p ^ k) ^ 2) = moebius_mu (p ^ k)" .
  qed

  have g_nonsquare: "g m = 0" if "\<not>is_square m" for m
  proof (cases "m = 0")
    case False
    from that False obtain p where p: "prime p" "odd (multiplicity p m)"
      using is_nth_power_conv_multiplicity_nat[of 2 m] by auto
    from p have "multiplicity p m \<noteq> 2" by auto
    moreover from p have "p \<in> prime_factors m"
      by (auto simp: prime_factors_multiplicity intro!: Nat.gr0I)
    ultimately have "(\<Prod>p\<in>prime_factors m. if multiplicity p m = 2 then - 1 else 0 :: real) = 0"
      (is "?P = _") by auto
    also have "?P = g m" using False by (subst g.prod_prime_factors') auto
    finally show ?thesis .
  qed auto

  have abs_g_le: "abs (g m) \<le> 1" for m
    by (cases "is_square m")
       (auto simp: g_square g_nonsquare abs_moebius_mu_le elim!: is_nth_powerE)

  have fds_g: "fds g = fds_ind squarefree * fds moebius_mu"
    by (rule fds_eqI) (simp add: g_def fds_nth_mult)
  have "fds g * fds_zeta = fds_ind squarefree * (fds_zeta * fds moebius_mu)"
    by (simp add: fds_g mult_ac)
  also have "fds_zeta * fds moebius_mu = (1 :: real fds)"
    by (rule fds_zeta_times_moebius_mu)
  finally have *: "fds_ind squarefree = fds g * fds_zeta" by simp
  have ind_squarefree: "ind squarefree = dirichlet_prod g f"
  proof
    fix n :: nat
    from * show "ind squarefree n = dirichlet_prod g f n"
      by (cases "n = 0") (simp_all add: fds_eq_iff fds_nth_mult f_def)
  qed

  define H :: "real \<Rightarrow> real"
    where "H = (\<lambda>x. sum_upto (\<lambda>m. g (m^2) * (real_of_int \<lfloor>x / real (m\<^sup>2)\<rfloor> - x / real (m^2))) (sqrt x))"
  define J where "J = (\<lambda>x::real. (\<Sum>n. moebius_mu (n + Suc (nat \<lfloor>x\<rfloor>)) / (n + Suc (nat \<lfloor>x\<rfloor>))^2))"

  have "eventually (\<lambda>x. norm (H x) \<le> 1 * norm (sqrt x)) at_top"
    using eventually_ge_at_top[of "0::real"]
  proof eventually_elim
    case (elim x)
    have "abs (H x) \<le> sum_upto (\<lambda>m. abs (g (m^2) * (real_of_int \<lfloor>x / real (m\<^sup>2)\<rfloor> -
                         x / real (m^2)))) (sqrt x)" (is "_ \<le> ?S") unfolding H_def sum_upto_def
      by (rule sum_abs)
    also have "x / (real m)\<^sup>2 - real_of_int \<lfloor>x / (real m)\<^sup>2\<rfloor> \<le> 1" for m by linarith
    hence "?S \<le> sum_upto (\<lambda>m. 1 * 1) (sqrt x)" unfolding abs_mult sum_upto_def
      by (intro sum_mono mult_mono abs_g_le) simp_all
    also have "\<dots> = of_int \<lfloor>sqrt x\<rfloor>" using elim by (simp add: sum_upto_altdef)
    also have "\<dots> \<le> sqrt x" by linarith
    finally show ?case using elim by simp
  qed
  hence H_bigo: "H \<in> O(\<lambda>x. sqrt x)" by (rule bigoI)

  let ?A = "\<lambda>x. card {n. real n \<le> x \<and> squarefree n}"
  have "eventually (\<lambda>x. ?A x - 6 / pi\<^sup>2 * x = (-x) * J (sqrt x) + H x) at_top"
    using eventually_ge_at_top[of "0::real"]
  proof eventually_elim
    fix x :: real assume x: "x \<ge> 0"
    have "{n. real n \<le> x \<and> squarefree n} = {n. n > 0 \<and> real n \<le> x \<and> squarefree n}"
      by (auto intro!: Nat.gr0I)
    also have "card \<dots> = sum_upto (ind squarefree :: nat \<Rightarrow> real) x"
      by (rule sum_upto_ind [symmetric])
    also have "\<dots> = sum_upto (\<lambda>d. g d * sum_upto f (x / real d)) x" (is "_ = ?S")
      unfolding ind_squarefree by (rule sum_upto_dirichlet_prod)
    also have "sum f {0<..nat \<lfloor>x / real i\<rfloor>} = of_int \<lfloor>x / real i\<rfloor>" if "i > 0" for i
      using x by (simp add: f_def)
    hence "?S = sum_upto (\<lambda>d. g d * of_int \<lfloor>x / real d\<rfloor>) x"
      unfolding sum_upto_altdef by (intro sum.cong refl) simp_all
    also have "\<dots> = sum_upto (\<lambda>m. g (m ^ 2) * of_int \<lfloor>x / real (m ^ 2)\<rfloor>) (sqrt x)"
      unfolding sum_upto_def
    proof (intro sum.reindex_bij_betw_not_neutral [symmetric])
      show "bij_betw power2 ({i. 0 < i \<and> real i \<le> sqrt x} - {})
              ({i. 0 < i \<and> real i \<le> x} - {i\<in>{0<..nat \<lfloor>x\<rfloor>}. \<not>is_square i})"
        by (auto simp: bij_betw_def inj_on_def power_eq_iff_eq_base le_sqrt_iff
                       is_nth_power_def le_nat_iff le_floor_iff)
    qed (auto simp: g_nonsquare)
    also have "\<dots> = x * sum_upto (\<lambda>m. g (m ^ 2) / real m ^ 2) (sqrt x) + H x"
      by (simp add: H_def sum_upto_def sum.distrib ring_distribs sum_subtractf
                    sum_distrib_left sum_distrib_right mult_ac)
    also have "sum_upto (\<lambda>m. g (m ^ 2) / real m ^ 2) (sqrt x) =
                 sum_upto (\<lambda>m. moebius_mu m / real m ^ 2) (sqrt x)"
      unfolding sum_upto_altdef by (intro sum.cong refl) (simp_all add: g_square)
    also have "sum_upto (\<lambda>m. moebius_mu m / (real m)\<^sup>2) (sqrt x) =
                 (\<Sum>m<Suc (nat \<lfloor>sqrt x\<rfloor>). moebius_mu m / (real m) ^ 2)"
      unfolding sum_upto_altdef by (intro sum.mono_neutral_cong_left) auto
    also have "\<dots> = (6 / pi^2 - J (sqrt x))"
      using sums_split_initial_segment[OF moebius_over_square_sums, of "Suc (nat \<lfloor>sqrt x\<rfloor>)"]
      by (auto simp: sums_iff algebra_simps J_def sum_upto_altdef)
    finally show "?A x - 6 / pi\<^sup>2 * x = (-x) * J (sqrt x) + H x"
      by (simp add: algebra_simps)
  qed
  hence "(\<lambda>x. ?A x - 6 / pi\<^sup>2 * x) \<in> \<Theta>(\<lambda>x. (-x) * J (sqrt x) + H x)"
    by (rule bigthetaI_cong)
  also have "(\<lambda>x. (-x) * J (sqrt x) + H x) \<in> O(\<lambda>x. sqrt x)"
  proof (intro sum_in_bigo H_bigo)
    have "(\<lambda>x. J (sqrt x)) \<in> O(\<lambda>x. 1 / sqrt x)" unfolding J_def
        using moebius_sum_tail_bigo sqrt_at_top by (rule landau_o.big.compose)
    hence "(\<lambda>x. (-x) * J (sqrt x)) \<in> O(\<lambda>x. x * (1 / sqrt x))"
      by (intro landau_o.big.mult) simp_all
    also have "(\<lambda>x::real. x * (1 / sqrt x)) \<in> \<Theta>(\<lambda>x. sqrt x)"
      by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::real"]])
         (auto simp: field_simps)
    finally show "(\<lambda>x. (-x) * J (sqrt x)) \<in> O(\<lambda>x. sqrt x)" .
  qed
  finally show ?thesis .
qed

theorem squarefree_asymptotics':
  "(\<lambda>x. card {n. real n \<le> x \<and> squarefree n}) =o (\<lambda>x. 6 / pi\<^sup>2 * x) +o O(\<lambda>x. sqrt x)"
  using squarefree_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem squarefree_asymptotics'':
  "(\<lambda>x. card {n. real n \<le> x \<and> squarefree n}) \<sim>[at_top] (\<lambda>x. 6 / pi\<^sup>2 * x)"
proof -
  have "(\<lambda>x. card {n. real n \<le> x \<and> squarefree n} - 6 / pi\<^sup>2 * x) \<in> O(\<lambda>x. sqrt x)"
    by (rule squarefree_asymptotics)
  also have "(sqrt :: real \<Rightarrow> real) \<in> \<Theta>(\<lambda>x. x powr (1/2))"
    by (intro bigthetaI_cong eventually_mono[OF eventually_ge_at_top[of "0::real"]])
       (auto simp: powr_half_sqrt)
  also have "(\<lambda>x::real. x powr (1/2)) \<in> o(\<lambda>x. 6 / pi ^ 2 * x)" by simp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

subsection \<open>The hyperbola method\<close>

lemma hyperbola_method_bigo:
  fixes f g :: "nat \<Rightarrow> 'a :: real_normed_field"
  assumes "(\<lambda>x. sum_upto (\<lambda>n. f n * sum_upto g (x / real n)) (sqrt x) - R x) \<in> O(b)"
  assumes "(\<lambda>x. sum_upto (\<lambda>n. sum_upto f (x / real n) * g n) (sqrt x) - S x) \<in> O(b)"
  assumes "(\<lambda>x. sum_upto f (sqrt x) * sum_upto g (sqrt x) - T x) \<in> O(b)"
  shows   "(\<lambda>x. sum_upto (dirichlet_prod f g) x - (R x + S x - T x)) \<in> O(b)"
proof -
  let ?A = "\<lambda>x. (sum_upto (\<lambda>n. f n * sum_upto g (x / real n)) (sqrt x) - R x) +
                (sum_upto (\<lambda>n. sum_upto f (x / real n) * g n) (sqrt x) - S x) +
                (-(sum_upto f (sqrt x) * sum_upto g (sqrt x) - T x))"
  have "(\<lambda>x. sum_upto (dirichlet_prod f g) x - (R x + S x - T x)) \<in> \<Theta>(?A)"
    by (intro bigthetaI_cong eventually_mono[OF eventually_ge_at_top[of "0::real"]])
       (auto simp: hyperbola_method_sqrt)
  also from assms have "?A \<in> O(b)"
    by (intro sum_in_bigo(1)) (simp_all only: landau_o.big.uminus_in_iff)
  finally show ?thesis .
qed

lemma frac_le_1: "frac x \<le> 1"
  unfolding frac_def by linarith

lemma ln_minus_ln_floor_bound:
  assumes "x \<ge> 2"
  shows   "ln x - ln (floor x) \<in> {0..<1 / (x - 1)}"
proof -
  from assms have "ln (floor x) \<ge> ln (x - 1)" by (subst ln_le_cancel_iff) simp_all
  hence "ln x - ln (floor x) \<le> ln ((x - 1) + 1) - ln (x - 1)" by simp
  also from assms have "\<dots> < 1 / (x - 1)" by (intro ln_diff_le_inverse) simp_all
  finally have "ln x - ln (floor x) < 1 / (x - 1)" by simp
  moreover from assms have "ln x \<ge> ln (of_int \<lfloor>x\<rfloor>)" by (subst ln_le_cancel_iff) simp_all
  ultimately show ?thesis by simp
qed

lemma ln_minus_ln_floor_bigo:
  "(\<lambda>x::real. ln x - ln (floor x)) \<in> O(\<lambda>x. 1 / x)"
proof -
  have "eventually (\<lambda>x. norm (ln x - ln (floor x)) \<le> 1 * norm (1 / (x - 1))) at_top"
    using eventually_ge_at_top[of "2::real"]
  proof eventually_elim
    case (elim x)
    with ln_minus_ln_floor_bound[OF this] show ?case by auto
  qed
  hence "(\<lambda>x::real. ln x - ln (floor x)) \<in> O(\<lambda>x. 1 / (x - 1))" by (rule bigoI)
  also have "(\<lambda>x::real. 1 / (x - 1)) \<in> O(\<lambda>x. 1 / x)" by simp
  finally show ?thesis .
qed

lemma divisor_count_asymptotics_aux:
  "(\<lambda>x. sum_upto (\<lambda>n. sum_upto (\<lambda>_. 1) (x / real n)) (sqrt x) -
                    (x * ln x / 2 + euler_mascheroni * x)) \<in> O(sqrt)"
proof -
  define R where "R = (\<lambda>x. \<Sum>i\<in>{0<..nat \<lfloor>sqrt x\<rfloor>}. frac (x / real i))"
  define S where "S = (\<lambda>x. ln (real (nat \<lfloor>sqrt x\<rfloor>)) - ln x / 2)"
  have R_bound: "R x \<in> {0..sqrt x}" if x: "x \<ge> 0" for x
  proof -
    have "R x \<le> (\<Sum>i\<in>{0<..nat \<lfloor>sqrt x\<rfloor>}. 1)" unfolding R_def by (intro sum_mono frac_le_1)
    also from x have "\<dots> = of_int \<lfloor>sqrt x\<rfloor>" by simp
    also have "\<dots> \<le> sqrt x" by simp
    finally have "R x \<le> sqrt x" .
    moreover have "R x \<ge> 0" unfolding R_def by (intro sum_nonneg) simp_all
    ultimately show ?thesis by simp
  qed
  have R_bound': "norm (R x) \<le> 1 * norm (sqrt x)" if "x \<ge> 0" for x
    using R_bound[OF that] that by simp
  have R_bigo: "R \<in> O(sqrt)" using eventually_ge_at_top[of "0::real"]
    by (intro bigoI[of _ 1], elim eventually_mono) (rule R_bound')

  have "eventually (\<lambda>x. sum_upto (\<lambda>n. sum_upto (\<lambda>_. 1 :: real) (x / real n)) (sqrt x) =
                          x * harm (nat \<lfloor>sqrt x\<rfloor>) - R x) at_top"
    using eventually_ge_at_top[of "0 :: real"]
  proof eventually_elim
    case (elim x)
    have "sum_upto (\<lambda>n. sum_upto (\<lambda>_. 1 :: real) (x / real n)) (sqrt x) =
            (\<Sum>i\<in>{0<..nat \<lfloor>sqrt x\<rfloor>}. of_int \<lfloor>x / real i\<rfloor>)" using elim
      by (simp add: sum_upto_altdef)
    also have "\<dots> = x * (\<Sum>i\<in>{0<..nat \<lfloor>sqrt x\<rfloor>}. 1 / real i) - R x"
      by (simp add: sum_subtractf frac_def R_def sum_distrib_left)
    also have "{0<..nat \<lfloor>sqrt x\<rfloor>} = {1..nat \<lfloor>sqrt x\<rfloor>}" by auto
    also have "(\<Sum>i\<in>\<dots>. 1 / real i) = harm (nat \<lfloor>sqrt x\<rfloor>)" by (simp add: harm_def divide_simps)
    finally show ?case .
  qed
  hence "(\<lambda>x. sum_upto (\<lambda>n. sum_upto (\<lambda>_. 1 :: real) (x / real n)) (sqrt x) -
                (x * ln x / 2 + euler_mascheroni * x)) \<in>
         \<Theta>(\<lambda>x. x * (harm (nat \<lfloor>sqrt x\<rfloor>) - (ln (nat \<lfloor>sqrt x\<rfloor>) + euler_mascheroni)) - R x + x * S x)"
   (is "_ \<in> \<Theta>(?A)")
   by (intro bigthetaI_cong) (elim eventually_mono, simp_all add: algebra_simps S_def)
  also have "?A \<in> O(sqrt)"
  proof (intro sum_in_bigo)
    have "(\<lambda>x. - S x) \<in> \<Theta>(\<lambda>x. ln (sqrt x) - ln (of_int \<lfloor>sqrt x\<rfloor>))"
      by (intro bigthetaI_cong eventually_mono [OF eventually_ge_at_top[of "1::real"]])
         (auto simp: S_def ln_sqrt)
    also have "(\<lambda>x. ln (sqrt x) - ln (of_int \<lfloor>sqrt x\<rfloor>)) \<in> O(\<lambda>x. 1 / sqrt x)"
      by (rule landau_o.big.compose[OF ln_minus_ln_floor_bigo sqrt_at_top])
    finally have "(\<lambda>x. x * S x) \<in> O(\<lambda>x. x * (1 / sqrt x))" by (intro landau_o.big.mult) simp_all
    also have "(\<lambda>x::real. x * (1 / sqrt x)) \<in> \<Theta>(\<lambda>x. sqrt x)"
      by (intro bigthetaI_cong eventually_mono [OF eventually_gt_at_top[of "0::real"]])
         (auto simp: field_simps)
    finally show "(\<lambda>x. x * S x) \<in> O(sqrt)" .
  next
    let ?f = "\<lambda>x::real. harm (nat \<lfloor>sqrt x\<rfloor>) - (ln (real (nat \<lfloor>sqrt x\<rfloor>)) + euler_mascheroni)"
    have "?f \<in> O(\<lambda>x. 1 / real (nat \<lfloor>sqrt x\<rfloor>))"
    proof (rule landau_o.big.compose[of _ _ _ "\<lambda>x. nat \<lfloor>sqrt x\<rfloor>"])
      show "filterlim (\<lambda>x::real. nat \<lfloor>sqrt x\<rfloor>) at_top at_top"
        by (intro filterlim_compose[OF filterlim_nat_sequentially]
                  filterlim_compose[OF filterlim_floor_sequentially] sqrt_at_top)
    next
      show "(\<lambda>a. harm a - (ln (real a) + euler_mascheroni)) \<in> O(\<lambda>a. 1 / real a)"
        by (rule harm_expansion_bigo_simple2)
    qed
    also have "(\<lambda>x. 1 / real (nat \<lfloor>sqrt x\<rfloor>)) \<in> O(\<lambda>x. 1 / (sqrt x - 1))"
    proof (rule bigoI[of _ 1], use eventually_ge_at_top[of 2] in eventually_elim)
      case (elim x)
      have "sqrt x \<le> 1 + real_of_int \<lfloor>sqrt x\<rfloor>" by linarith
      with elim show ?case by (simp add: field_simps)
    qed
    also have "(\<lambda>x::real. 1 / (sqrt x - 1)) \<in> O(\<lambda>x. 1 / sqrt x)"
      by (rule landau_o.big.compose[OF _ sqrt_at_top]) simp_all
    finally have "(\<lambda>x. x * ?f x) \<in> O(\<lambda>x. x * (1 / sqrt x))"
      by (intro landau_o.big.mult landau_o.big_refl)
    also have "(\<lambda>x::real. x * (1 / sqrt x)) \<in> \<Theta>(\<lambda>x. sqrt x)"
      by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::real"]])
         (auto elim!: eventually_mono simp: field_simps)
    finally show "(\<lambda>x. x * ?f x) \<in> O(sqrt)" .
  qed fact+
  finally show ?thesis .
qed

lemma sum_upto_sqrt_bound:
  assumes x: "x \<ge> (0 :: real)"
  shows   "norm ((sum_upto (\<lambda>_. 1) (sqrt x))\<^sup>2 - x) \<le> 2 * norm (sqrt x)"
proof -
  from x have "0 \<le> 2 * sqrt x * (1 - frac (sqrt x)) + frac (sqrt x) ^ 2"
    by (intro add_nonneg_nonneg mult_nonneg_nonneg) (simp_all add: frac_le_1)
  also from x have "\<dots> = (sqrt x - frac (sqrt x)) ^ 2 - x + 2 * sqrt x"
    by (simp add: algebra_simps power2_eq_square)
  also have "sqrt x - frac (sqrt x) = of_int \<lfloor>sqrt x\<rfloor>" by (simp add: frac_def)
  finally have "(of_int \<lfloor>sqrt x\<rfloor>) ^ 2 - x \<ge> -2 * sqrt x" by (simp add: algebra_simps)
  moreover from x have "of_int (\<lfloor>sqrt x\<rfloor>) ^ 2 \<le> sqrt x ^ 2"
    by (intro power_mono) simp_all
  with x have "of_int (\<lfloor>sqrt x\<rfloor>) ^ 2 - x \<le> 0" by simp
  ultimately have "sum_upto (\<lambda>_. 1) (sqrt x) ^ 2 - x \<in> {-2 * sqrt x..0}"
    using x by (simp add: sum_upto_altdef)
  with x show ?thesis by simp
qed

lemma summatory_divisor_count_asymptotics:
  "(\<lambda>x. sum_upto (\<lambda>n. real (divisor_count n)) x -
          (x * ln x + (2 * euler_mascheroni - 1) * x)) \<in> O(sqrt)"
proof -
  let ?f = "\<lambda>x. x * ln x / 2 + euler_mascheroni * x"
  have "(\<lambda>x. sum_upto (dirichlet_prod (\<lambda>_. 1 :: real) (\<lambda>_. 1)) x - (?f x + ?f x - x)) \<in> O(sqrt)"
    (is "?g \<in> _")
  proof (rule hyperbola_method_bigo)
    have "eventually (\<lambda>x::real. norm (sum_upto (\<lambda>_. 1) (sqrt x) ^ 2 - x) \<le>
             2 * norm (sqrt x)) at_top"
      using eventually_ge_at_top[of "0::real"] by eventually_elim (rule sum_upto_sqrt_bound)
    thus "(\<lambda>x::real. sum_upto (\<lambda>_. 1) (sqrt x) * sum_upto (\<lambda>_. 1) (sqrt x) - x) \<in> O(sqrt)"
      by (intro bigoI[of _ 2]) (simp_all add: power2_eq_square)
  next
    show "(\<lambda>x. sum_upto (\<lambda>n. 1 * sum_upto (\<lambda>_. 1) (x / real n)) (sqrt x) -
                 (x * ln x / 2 + euler_mascheroni * x)) \<in> O(sqrt)"
      using divisor_count_asymptotics_aux by simp
  next
    show "(\<lambda>x. sum_upto (\<lambda>n. sum_upto (\<lambda>_. 1) (x / real n) * 1) (sqrt x) -
                 (x * ln x / 2 + euler_mascheroni * x)) \<in> O(sqrt)"
      using divisor_count_asymptotics_aux by simp
  qed
  also have "divisor_count n = dirichlet_prod (\<lambda>_. 1) (\<lambda>_. 1) n" for n
    using fds_divisor_count
    by (cases "n = 0") (simp_all add: fds_eq_iff power2_eq_square fds_nth_mult)
  hence "?g = (\<lambda>x. sum_upto (\<lambda>n. real (divisor_count n)) x -
               (x * ln x + (2 * euler_mascheroni - 1) * x))"
    by (intro ext) (simp_all add: algebra_simps dirichlet_prod_def)
  finally show ?thesis .
qed

theorem summatory_divisor_count_asymptotics':
  "(\<lambda>x. sum_upto (\<lambda>n. real (divisor_count n)) x) =o
     (\<lambda>x. x * ln x + (2 * euler_mascheroni - 1) * x) +o O(\<lambda>x. sqrt x)"
  using summatory_divisor_count_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem summatory_divisor_count_asymptotics'':
  "sum_upto (\<lambda>n. real (divisor_count n)) \<sim>[at_top] (\<lambda>x. x * ln x)"
proof -
  have "(\<lambda>x. sum_upto (\<lambda>n. real (divisor_count n)) x -
           (x * ln x + (2 * euler_mascheroni - 1) * x)) \<in> O(sqrt)"
    by (rule summatory_divisor_count_asymptotics)
  also have "sqrt \<in> \<Theta>(\<lambda>x. x powr (1/2))"
    by (intro bigthetaI_cong eventually_mono [OF eventually_ge_at_top[of "0::real"]])
       (auto elim!: eventually_mono simp: powr_half_sqrt)
  also have "(\<lambda>x::real. x powr (1/2)) \<in> o(\<lambda>x. x * ln x + (2 * euler_mascheroni - 1) * x)" by simp
  finally have "sum_upto (\<lambda>n. real (divisor_count n)) \<sim>[at_top]
                  (\<lambda>x. x * ln x + (2 * euler_mascheroni - 1) * x)"
    by (simp add: asymp_equiv_altdef)
  also have "\<dots> \<sim>[at_top] (\<lambda>x. x * ln x)" by (subst asymp_equiv_add_right) simp_all
  finally show ?thesis .
qed

lemma summatory_divisor_eq:
  "sum_upto (\<lambda>n. real (divisor_count n)) (real m) = card {(n,d). n \<in> {0<..m} \<and> d dvd n}"
proof -
  have "sum_upto (\<lambda>n. real (divisor_count n)) m = card (SIGMA n:{0<..m}. {d. d dvd n})"
    unfolding sum_upto_altdef divisor_count_def by (subst card_SigmaI) simp_all
  also have "(SIGMA n:{0<..m}. {d. d dvd n}) = {(n,d). n \<in> {0<..m} \<and> d dvd n}" by auto
  finally show ?thesis .
qed

context
  fixes M :: "nat \<Rightarrow> real"
  defines "M \<equiv> \<lambda>m. card {(n,d). n \<in> {0<..m} \<and> d dvd n} / card {0<..m}"
begin

lemma mean_divisor_count_asymptotics:
  "(\<lambda>m. M m - (ln m + 2 * euler_mascheroni - 1)) \<in> O(\<lambda>m. 1 / sqrt m)"
proof -
  have "(\<lambda>m. M m - (ln m + 2 * euler_mascheroni - 1))
          \<in> \<Theta>(\<lambda>m. (sum_upto (\<lambda>n. real (divisor_count n)) (real m) -
                 (m * ln m + (2 * euler_mascheroni - 1) * m)) / m)" (is "_ \<in> \<Theta>(?f)")
    unfolding M_def
    by (intro bigthetaI_cong eventually_mono [OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: summatory_divisor_eq field_simps)
  also have "?f \<in> O(\<lambda>m. sqrt m / m)"
    by (intro landau_o.big.compose[OF _ filterlim_real_sequentially] landau_o.big.divide_right
          summatory_divisor_count_asymptotics eventually_at_top_not_equal)
  also have "(\<lambda>m::nat. sqrt m / m) \<in> \<Theta>(\<lambda>m. 1 / sqrt m)"
    by (intro bigthetaI_cong eventually_mono [OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: field_simps)
  finally show ?thesis .
qed

theorem mean_divisor_count_asymptotics':
  "M =o (\<lambda>x. ln x + 2 * euler_mascheroni - 1) +o O(\<lambda>x. 1 / sqrt x)"
  using mean_divisor_count_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem mean_divisor_count_asymptotics'': "M \<sim>[at_top] ln"
proof -
  have "(\<lambda>x. M x - (ln x + 2 * euler_mascheroni - 1)) \<in> O(\<lambda>x. 1 / sqrt x)"
    by (rule mean_divisor_count_asymptotics)
  also have "(\<lambda>x. 1 / sqrt (real x)) \<in> \<Theta>(\<lambda>x. x powr (-1/2))"
    using eventually_gt_at_top[of "0::nat"]
    by (intro bigthetaI_cong)
       (auto elim!: eventually_mono simp: powr_half_sqrt field_simps powr_minus)
  also have "(\<lambda>x::nat. x powr (-1/2)) \<in> o(\<lambda>x. ln x + 2 * euler_mascheroni - 1)"
    by (intro smallo_real_nat_transfer) simp_all
  finally have "M \<sim>[at_top] (\<lambda>x. ln x + 2 * euler_mascheroni - 1)"
    by (simp add: asymp_equiv_altdef)
  also have "\<dots> = (\<lambda>x::nat. ln x + (2 * euler_mascheroni - 1))" by (simp add: algebra_simps)
  also have "\<dots> \<sim>[at_top] (\<lambda>x::nat. ln x)" by (subst asymp_equiv_add_right) auto
  finally show ?thesis .
qed

end

subsection \<open>The asymptotic ditribution of coprime pairs\<close>

context
  fixes A :: "nat \<Rightarrow> (nat \<times> nat) set"
  defines "A \<equiv> (\<lambda>N. {(m,n) \<in> {1..N} \<times> {1..N}. coprime m n})"
begin

lemma coprime_pairs_asymptotics:
  "(\<lambda>N. real (card (A N)) - 6 / pi\<^sup>2 * (real N)\<^sup>2) \<in> O(\<lambda>N. real N * ln (real N))"
proof -
  define C :: "nat \<Rightarrow> (nat \<times> nat) set"
    where "C = (\<lambda>N. (\<Union>m\<in>{1..N}. (\<lambda>n. (m,n)) ` totatives m))"
  define D :: "nat \<Rightarrow> (nat \<times> nat) set"
    where "D = (\<lambda>N. (\<Union>n\<in>{1..N}. (\<lambda>m. (m,n)) ` totatives n))"
  have fin: "finite (C N)" "finite (D N)" for N unfolding C_def D_def
    by (intro finite_UN_I finite_imageI; simp)+

  have *: "card (A N) = 2 * (\<Sum>m\<in>{0<..N}. totient m) - 1" if N: "N > 0" for N
  proof -
    have "A N = C N \<union> D N"
      by (auto simp add: A_def C_def D_def totatives_def image_iff ac_simps)
    also have "card \<dots> = card (C N) + card (D N) - card (C N \<inter> D N)"
      using card_Un_Int[OF fin[of N]] by arith
    also have "C N \<inter> D N = {(1, 1)}" using N by (auto simp: image_iff totatives_def C_def D_def)
    also have "D N = (\<lambda>(x,y). (y,x)) ` C N" by (simp add: image_UN image_image C_def D_def)
    also have "card \<dots> = card (C N)" by (rule card_image) (simp add: inj_on_def C_def)
    also have "card (C N) = (\<Sum>m\<in>{1..N}. card ((\<lambda>n. (m,n)) ` totatives m))"
      unfolding C_def by (intro card_UN_disjoint) auto
    also have "\<dots> = (\<Sum>m\<in>{1..N}. totient m)" unfolding totient_def
      by (subst card_image) (auto simp: inj_on_def)
    also have "\<dots> = (\<Sum>m\<in>{0<..N}. totient m)" by (intro sum.cong refl) auto
    finally show "card (A N) = 2 * \<dots> - 1" by simp
  qed
  have **: "(\<Sum>m\<in>{0<..N}. totient m) \<ge> 1" if "N \<ge> 1" for N
  proof -
    have "1 \<le> N" by fact
    also have "N = (\<Sum>m\<in>{0<..N}. 1)" by simp
    also have "(\<Sum>m\<in>{0<..N}. 1) \<le> (\<Sum>m\<in>{0<..N}. totient m)"
      by (intro sum_mono) (simp_all add: Suc_le_eq)
    finally show ?thesis .
  qed

  have "(\<lambda>N. real (card (A N)) - 6 / pi\<^sup>2 * (real N)\<^sup>2) \<in>
          \<Theta>(\<lambda>N. 2 * (sum_upto (\<lambda>m. real (totient m)) (real N) - (3 / pi\<^sup>2 * (real N)\<^sup>2)) - 1)"
    (is "_ \<in> \<Theta>(?f)") using * **
    by (intro bigthetaI_cong eventually_mono [OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: of_nat_diff sum_upto_altdef)
  also have "?f \<in> O(\<lambda>N. real N * ln (real N))"
  proof (rule landau_o.big.compose[OF _ filterlim_real_sequentially], rule sum_in_bigo)
    show " (\<lambda>x. 2 * (sum_upto (\<lambda>m. real (totient m)) x - 3 / pi\<^sup>2 * x\<^sup>2)) \<in> O(\<lambda>x. x * ln x)"
      by (subst landau_o.big.cmult_in_iff, simp, rule summatory_totient_asymptotics)
  qed simp_all
  finally show ?thesis .
qed

theorem coprime_pairs_asymptotics':
  "(\<lambda>N. real (card (A N))) =o (\<lambda>N. 6 / pi\<^sup>2 * (real N)\<^sup>2) +o O(\<lambda>N. real N * ln (real N))"
  using coprime_pairs_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem coprime_pairs_asymptotics'':
  "(\<lambda>N. real (card (A N))) \<sim>[at_top] (\<lambda>N. 6 / pi\<^sup>2 * (real N)\<^sup>2)"
proof -
  have "(\<lambda>N. real (card (A N)) - 6 / pi\<^sup>2 * (real N) ^ 2) \<in> O(\<lambda>N. real N * ln (real N))"
    by (rule coprime_pairs_asymptotics)
  also have "(\<lambda>N. real N * ln (real N)) \<in> o(\<lambda>N. 6 / pi ^ 2 * real N ^ 2)"
    by (rule landau_o.small.compose[OF _ filterlim_real_sequentially]) simp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

theorem coprime_probability_tendsto:
  "(\<lambda>N. card (A N) / card ({1..N} \<times> {1..N})) \<longlonglongrightarrow> 6 / pi\<^sup>2"
proof -
  have "(\<lambda>N. 6 / pi ^ 2) \<sim>[at_top] (\<lambda>N. 6 / pi ^ 2 * real N ^ 2 / real N ^ 2)"
    using eventually_gt_at_top[of "0::nat"]
    by (intro asymp_equiv_refl_ev) (auto elim!: eventually_mono)
  also have "\<dots> \<sim>[at_top] (\<lambda>N. real (card (A N)) / real N ^ 2)"
    by (intro asymp_equiv_intros asymp_equiv_symI[OF coprime_pairs_asymptotics''])
  also have "\<dots> \<sim>[at_top] (\<lambda>N. real (card (A N)) / real (card ({1..N} \<times> {1..N})))"
    by (simp add: power2_eq_square)
  finally have "\<dots> \<sim>[at_top] (\<lambda>_. 6 / pi ^ 2)" by (simp add: asymp_equiv_sym)
  thus ?thesis by (rule asymp_equivD_const)
qed

end

subsection \<open>The asymptotics of the number of Farey fractions\<close>

definition farey_fractions :: "nat \<Rightarrow> rat set" where
  "farey_fractions N = {q :: rat \<in> {0<..1}. snd (quotient_of q) \<le> int N}  "

lemma Fract_eq_coprime:
  assumes "Rat.Fract a b = Rat.Fract c d" "b > 0" "d > 0" "coprime a b" "coprime c d"
  shows   "a = c" "b = d"
proof -
  from assms have "a * d = c * b" by (auto simp: eq_rat)
  hence "abs (a * d) = abs (c * b)" by (simp only:)
  hence "abs a * abs d = abs c * abs b" by (simp only: abs_mult)
  also have "?this \<longleftrightarrow> abs a = abs c \<and> d = b"
    using assms by (subst coprime_crossproduct_int) simp_all
  finally show "b = d" by simp
  with \<open>a * d = c * b\<close> and \<open>b > 0\<close> show "a = c" by simp
qed

lemma quotient_of_split:
  "P (quotient_of q) = (\<forall>a b. b > 0 \<longrightarrow> coprime a b \<longrightarrow> q = Rat.Fract a b \<longrightarrow> P (a, b))"
  by (cases q) (auto simp: quotient_of_Fract dest: Fract_eq_coprime)

lemma quotient_of_split_asm:
  "P (Rat.quotient_of q) = (\<not>(\<exists>a b. b > 0 \<and> coprime a b \<and> q = Rat.Fract a b \<and> \<not>P (a, b)))"
  using quotient_of_split[of P q] by blast

lemma farey_fractions_bij:
  "bij_betw (\<lambda>(a,b). Rat.Fract (int a) (int b))
     {(a,b)|a b. 0 < a \<and> a \<le> b \<and> b \<le> N \<and> coprime a b} (farey_fractions N)"
proof (rule bij_betwI[of _ _ _ "\<lambda>q. case quotient_of q of (a, b) \<Rightarrow> (nat a, nat b)"], goal_cases)
  case 1
  show ?case
    by (auto simp: farey_fractions_def Rat.zero_less_Fract_iff Rat.Fract_le_one_iff
                   Rat.quotient_of_Fract Rat.normalize_def gcd_int_def Let_def)
next
  case 2
  show ?case
    by (auto simp add: farey_fractions_def Rat.Fract_le_one_iff Rat.zero_less_Fract_iff split: prod.splits quotient_of_split_asm)
      (simp add: coprime_int_iff [symmetric])
next
  case (3 x)
  thus ?case by (auto simp: Rat.quotient_of_Fract Rat.normalize_def Let_def gcd_int_def)
next
  case (4 x)
  thus ?case unfolding farey_fractions_def
    by (split quotient_of_split) (auto simp: Rat.zero_less_Fract_iff)
qed

lemma card_farey_fractions: "card (farey_fractions N) = sum totient {0<..N}"
proof -
  have "card (farey_fractions N) = card {(a,b)|a b. 0 < a \<and> a \<le> b \<and> b \<le> N \<and> coprime a b}"
    using farey_fractions_bij by (rule bij_betw_same_card [symmetric])
  also have "{(a,b)|a b. 0 < a \<and> a \<le> b \<and> b \<le> N \<and> coprime a b} =
               (\<Union>b\<in>{0<..N}. (\<lambda>a. (a, b)) ` totatives b)"
    by (auto simp: totatives_def image_iff)
  also have "card \<dots> = (\<Sum>b\<in>{0<..N}. card ((\<lambda>a. (a, b)) ` totatives b))"
    by (intro card_UN_disjoint) auto
  also have "\<dots> = (\<Sum>b\<in>{0<..N}. totient b)"
    unfolding totient_def by (intro sum.cong refl card_image) (auto simp: inj_on_def)
  finally show ?thesis .
qed

lemma card_farey_fractions_asymptotics:
  "(\<lambda>N. real (card (farey_fractions N)) - 3 / pi\<^sup>2 * (real N)\<^sup>2) \<in> O(\<lambda>N. real N * ln (real N))"
proof -
  have "(\<lambda>N. sum_upto (\<lambda>n. real (totient n)) (real N) - 3 / pi\<^sup>2 * (real N)\<^sup>2)
            \<in> O(\<lambda>N. real N * ln (real N))" (is "?f \<in> _")
    using summatory_totient_asymptotics filterlim_real_sequentially
    by (rule landau_o.big.compose)
  also have "?f = (\<lambda>N. real (card (farey_fractions N)) - 3 / pi\<^sup>2 * (real N)\<^sup>2)"
    by (intro ext) (simp add: sum_upto_altdef card_farey_fractions)
  finally show ?thesis .
qed

theorem card_farey_fractions_asymptotics':
  "(\<lambda>N. card (farey_fractions N)) =o (\<lambda>N. 3 / pi\<^sup>2 * N^2) +o O(\<lambda>N. N * ln N)"
  using card_farey_fractions_asymptotics
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

theorem card_farey_fractions_asymptotics'':
  "(\<lambda>N. real (card (farey_fractions N))) \<sim>[at_top] (\<lambda>N. 3 / pi\<^sup>2 * (real N)\<^sup>2)"
proof -
  have "(\<lambda>N. real (card (farey_fractions N)) - 3 / pi\<^sup>2 * (real N) ^ 2) \<in> O(\<lambda>N. real N * ln (real N))"
    by (rule card_farey_fractions_asymptotics)
  also have "(\<lambda>N. real N * ln (real N)) \<in> o(\<lambda>N. 3 / pi ^ 2 * real N ^ 2)"
    by (rule landau_o.small.compose[OF _ filterlim_real_sequentially]) simp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Generality of the Algorithm to transform from diagonal to Smith normal form\<close>

theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring
  imports
  Diagonal_To_Smith
  Rings2_Extended
  Smith_Normal_Form_JNF
  Finite_Field_Mod_Type_Connection
begin

hide_const (open) mat

text \<open>This section provides a formal proof on the generality of the algorithm that transforms
a diagonal matrix into its Smith normal form. More concretely, we prove that
all diagonal matrices with coefficients in a ring R admit Smith normal form if and only if
R is a B\'ezout ring.

Since our algorithm is defined for B\'ezout rings and for any matrices (including non-square and
singular ones), this means that it does not exist another algorithm that performs the transformation
in a more abstract structure.\<close>

text \<open>Firstly, we hide some definitions and facts, since we are interested in the ones
developed for the @{text "mod_type"} class.\<close>

hide_const (open) Bij_Nat.to_nat Bij_Nat.from_nat Countable.to_nat Countable.from_nat
hide_fact (open) Bij_Nat.to_nat_from_nat_id Bij_Nat.to_nat_less_card

definition "admits_SNF_HA (A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) = (isDiagonal A
    \<longrightarrow> (\<exists>P Q. invertible ((P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}))
        \<and> invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) \<and> Smith_normal_form (P**A**Q)))"

definition "admits_SNF_JNF A = (square_mat (A::'a::comm_ring_1 mat) \<and> isDiagonal_mat A
  \<longrightarrow> (\<exists>P Q. P \<in> carrier_mat (dim_row A) (dim_row A) \<and> Q \<in> carrier_mat (dim_row A) (dim_row A)
    \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat (P*A*Q)))"

subsection \<open>Proof of the  @{text "\<Longleftarrow>"} implication in HA.\<close>

lemma exists_f_PAQ_Aii':
  fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
  assumes diag_A: "isDiagonal A"
  shows "\<exists>f. (P**A**Q) $h i $h i = (\<Sum>i\<in>(UNIV::'n set). f i * A $h i $h i)"
proof -
  have rw: "(\<Sum>ka\<in>UNIV. P $h i $h ka * A $h ka $h k) = P $h i $h k * A $h k $h k" for k
  proof -
    have "(\<Sum>ka\<in>UNIV. P $h i $h ka * A $h ka $h k) = (\<Sum>ka\<in>{k}. P $h i $h ka * A $h ka $h k)"
    proof (rule sum.mono_neutral_right, auto)
      fix ia assume "P $h i $h ia * A $h ia $h k \<noteq> 0"
      hence "A $h ia $h k \<noteq> 0" by auto
      thus" ia = k" using diag_A unfolding isDiagonal_def by auto
    qed
    also have "... = P $h i $h k * A $h k $h k" by auto
    finally show ?thesis .
  qed
  let ?f = "\<lambda>k. (\<Sum>ka\<in>UNIV. P $h i $h ka) * Q $h k $h i"
  have "(P**A**Q) $h i $h i = (\<Sum>k\<in>UNIV. (\<Sum>ka\<in>UNIV. P $h i $h ka * A $h ka $h k) * Q $h k $h i)"
    unfolding matrix_matrix_mult_def by auto
  also have "... = (\<Sum>k\<in>UNIV.  P $h i $h k * Q $h k $h i * A $h k $h k)"
    unfolding rw
    by (meson semiring_normalization_rules(16))
  finally show ?thesis by auto
qed

(*We would like to have the theorems within contexts:

context semiring_1
begin

lemma foo1:
  fixes foo::"'a::type\<Rightarrow>'a\<Rightarrow>'a"
  shows "foo a = c"
  sorry

end

where 'a has simply type "type". This way, we could have
thm semiring_1.foo

Which is: class.semiring_1 ?one ?times ?plus ?zero \<Longrightarrow> ?foo ?a = ?c

However, many of them are proven with type restrictions instead of being proved within a context.
For example:

lemma foo2:
  fixes foo::"'a::semiring_1\<Rightarrow>'a\<Rightarrow>'a"
  shows "foo a = c" sorry

To convert foo2 to a statement like foo1, we need interalize_sort developed in From Types to Sets.

lemmas foo2 = foo1[internalize_sort "'a :: semiring_1"]
*)

text \<open>We apply @{text "internalize_sort"} to the lemma that we need\<close>

lemmas diagonal_to_Smith_PQ_exists_internalize_sort
  = diagonal_to_Smith_PQ_exists[internalize_sort "'a :: bezout_ring"]

text \<open>We get the @{text "\<Longleftarrow>"} implication in HA.\<close>

lemma bezout_ring_imp_diagonal_admits_SNF:
  assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  shows "\<forall>A::'a^'n::{mod_type}^'n::{mod_type}. isDiagonal A
    \<longrightarrow> (\<exists>P Q.
        invertible (P::'a^'n::mod_type^'n::mod_type) \<and>
        invertible (Q::'a^'n::mod_type^'n::mod_type) \<and>
        Smith_normal_form (P**A**Q))"
proof (rule allI, rule impI)
  fix A::"'a^'n::{mod_type}^'n::{mod_type}"
  assume A: "isDiagonal A"
  have br: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus"
    by (rule OFCLASS_bezout_ring_imp_class_bezout_ring[OF of])
  show "\<exists>P Q.
        invertible (P::'a^'n::mod_type^'n::mod_type) \<and>
        invertible (Q::'a^'n::mod_type^'n::mod_type) \<and>
        Smith_normal_form (P**A**Q)" by (rule diagonal_to_Smith_PQ_exists_internalize_sort[OF br A])
qed

subsection \<open>Trying to prove the @{text "\<Longrightarrow>"} implication in HA.\<close>

text\<open>There is a problem: we need to define a matrix with a concrete dimension, which is not
  possible in HA (the dimension depends on the number of elements on a set, and Isabelle/HOL does
  not feature dependent types)\<close>

lemma
  assumes "\<forall>A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops

(*
lemma
  assumes "\<forall>A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A
    \<longrightarrow> (\<exists>P Q. invertible P \<and> invertible Q \<and> Smith_normal_form (P**A**Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI)
  fix I::"'a set"
  assume fin: "finitely_generated_ideal I"
  obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S"
    using fin unfolding finitely_generated_ideal_def by auto
  obtain xs where set_xs: "set xs = S" and d: "distinct xs"
    using finite_distinct_list[OF fin_S] by blast
  hence length_eq_card: "length xs = card S" using distinct_card by force
(*
  The proof requires:
  1) Obtain a matrix A whose diagonal entries are the elements of xs
  2) Transform such a matrix A into its Smith normal form by means of elementary operations
  3) Put the diagonal entries of the matrix in Smith normal form as a list ys.
  4) Proof that the first element of ys divides all the other elements of such a list.
  5) Show that, ideal_generated (set xs) = ideal_generated (set ys) = ideal_generated (ys!0).
*)
  show "principal_ideal I"

qed

(*Alternative statement (same problems)*)

lemma
  assumes "\<forall>A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops
*)

subsection \<open>Proof of the  @{text "\<Longrightarrow>"}  implication in JNF.\<close>

lemma exists_f_PAQ_Aii:
  assumes diag_A: "isDiagonal_mat (A::'a:: comm_ring_1 mat)"
    and P: "P \<in> carrier_mat n n"
    and A: "A \<in> carrier_mat n n"
    and Q: "Q \<in> carrier_mat n n"
    and i: "i < n"
  (*  and d: "distinct (diag_mat A)" (*With some work, this assumption can be removed.*)*)
  shows "\<exists>f. (P*A*Q) $$ (i, i) = (\<Sum>i\<in>set (diag_mat A). f i * i)"
proof -
  let ?xs = "diag_mat A"
  let ?n = "length ?xs"
  have length_n: "length (diag_mat A) = n"
    by (metis A carrier_matD(1) diag_mat_def diff_zero length_map length_upt)
  have xs_index: "?xs ! i = A $$ (i, i)" if "i<n" for i
    by (metis (no_types, lifting) add.left_neutral diag_mat_def length_map
        length_n length_upt nth_map_upt that)
  have i_length: "i<length ?xs" using i length_n by auto
  have rw: "(\<Sum>ka = 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = P $$(i, k) * A $$ (k, k)"
    if k: "k<length ?xs" for k
  proof -
    have "(\<Sum>ka= 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = (\<Sum>ka\<in>{k}. P $$ (i, ka) * A $$ (ka, k))"
      by (rule sum.mono_neutral_right, auto simp add: k,
          insert diag_A A length_n that, unfold isDiagonal_mat_def, fastforce)
    also have "... = P $$(i, k) * A $$ (k, k)" by auto
    finally show ?thesis .
  qed
  let ?positions_of ="\<lambda>x. {i. A$$(i,i) = x \<and> i<length ?xs}"
  let ?T="set ?xs"
  let ?S ="{0..<?n}"
  let ?f = "\<lambda>x.(\<Sum>k\<in>{i. A $$ (i, i) = x \<and> i < length (diag_mat A)}. P $$ (i, k) * Q $$ (k, i))"
  let ?g = "(\<lambda>k. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
  have UNION_positions_of: "\<Union>(?positions_of ` ?T) = ?S" unfolding diag_mat_def by auto
  have "(P*A*Q) $$ (i,i) = (\<Sum>ia = 0..<?n.
        Matrix.row (Matrix.mat ?n ?n (\<lambda>(i, j). \<Sum>ia = 0..<?n.
        Matrix.row P i $v ia * col A j $v ia)) i $v ia * col Q i $v ia)"
    unfolding times_mat_def scalar_prod_def
    using P Q i_length length_n A by auto
  also have "... = (\<Sum>k = 0..<?n. (\<Sum>ka = 0..<?n. P$$(i,ka) * A$$(ka,k)) * Q $$ (k,i))"
  proof (rule sum.cong, auto)
    fix x assume x: "x < length ?xs"
    have rw_colQ: "col Q i $v x = Q $$ (x, i)"
      using Q i_length x length_n A by auto
    have rw2: " Matrix.row (Matrix.mat ?n ?n
            (\<lambda>(i, j). \<Sum>ia = 0..<length ?xs. Matrix.row P i $v ia * col A j $v ia)) i $v x
            =(\<Sum>ia = 0..<length ?xs. Matrix.row P i $v ia * col A x $v ia)"
      unfolding row_mat[OF i_length] unfolding index_vec[OF x] by auto
    also have "... = (\<Sum>ia = 0..<length ?xs.  P $$ (i,ia) * A $$ (ia,x))"
      by (rule sum.cong, insert P i_length x length_n A, auto)
    finally show "Matrix.row (Matrix.mat ?n ?n (\<lambda>(i, j). \<Sum>ia = 0..<?n. Matrix.row P i $v ia
            * col A j $v ia)) i $v x * col Q i $v x
            = (\<Sum>ka = 0..<?n. P $$ (i, ka) * A $$ (ka, x)) * Q $$ (x, i)" unfolding rw_colQ by auto
  qed
  also have "... = (\<Sum>k = 0..<?n. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
    by (smt rw semiring_normalization_rules(16) sum.ivl_cong)
  also have "... = sum ?g (\<Union>(?positions_of ` ?T))"
    using UNION_positions_of by auto
  also have "... = (\<Sum>x\<in>?T. sum ?g (?positions_of x))"
    by (rule sum.UNION_disjoint, auto)
  also have "... = (\<Sum>x\<in>set (diag_mat A). (\<Sum>k\<in>{i. A $$ (i, i) = x \<and> i < length (diag_mat A)}.
    P $$ (i, k) * Q $$ (k, i)) * x)"
    by (rule sum.cong, auto simp add: Groups_Big.sum_distrib_right)
  finally show ?thesis by auto
qed

text \<open>Proof of the @{text "\<Longrightarrow>"} implication in JNF.\<close>

lemma diagonal_admits_SNF_imp_bezout_ring_JNF:
  assumes admits_SNF: "\<forall>A n. (A::'a mat) \<in> carrier_mat n n \<and> isDiagonal_mat A
  \<longrightarrow> (\<exists>P Q. P \<in> carrier_mat n n \<and> Q \<in> carrier_mat n n \<and> invertible_mat P \<and> invertible_mat Q
      \<and> Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI)
  fix I::"'a set"
  assume fin: "finitely_generated_ideal I"
  obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S"
    using fin unfolding finitely_generated_ideal_def by auto
  show "principal_ideal I"
  proof (cases "S = {}")
    case True
    then show ?thesis
      by (metis ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def)
  next
    case False
    obtain xs where set_xs: "set xs = S" and d: "distinct xs"
      using finite_distinct_list[OF fin_S] by blast
    hence length_eq_card: "length xs = card S" using distinct_card by force
    let ?n = "length xs"
    let ?A = "Matrix.mat ?n ?n (\<lambda>(a,b). if a = b then xs!a else 0)"
    have A_carrier: "?A \<in> carrier_mat ?n ?n" by auto
    have diag_A: "isDiagonal_mat ?A" unfolding isDiagonal_mat_def by auto
    have set_xs_eq: "set xs = {?A$$(i,i)| i. i<dim_row ?A}"
      by (auto, smt case_prod_conv d distinct_Ex1 index_mat(1))
    have set_xs_diag_mat: "set xs = set (diag_mat ?A)"
      using set_xs_eq unfolding diag_mat_def by auto
    obtain P Q where P: "P \<in> carrier_mat ?n ?n"
      and Q: "Q \<in> carrier_mat ?n ?n" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
      and SNF_PAQ: "Smith_normal_form_mat (P*?A*Q)"
      using admits_SNF A_carrier diag_A by blast
    define ys where ys_def: "ys = diag_mat (P*?A*Q)"
    have ys: "\<forall>i<?n. ys ! i = (P*?A*Q) $$ (i,i)" using P by (auto simp add: ys_def diag_mat_def)
    have length_ys: "length ys = ?n" unfolding ys_def
      by (metis (no_types, lifting) P carrier_matD(1) diag_mat_def
          index_mult_mat(2) length_map map_nth)
    have n0: "?n > 0" using False set_xs by blast
    have set_ys_diag_mat: "set ys = set (diag_mat (P*?A*Q))" using ys_def by auto
    let ?i = "ys ! 0"
    have dvd_all: "\<forall>a \<in> set ys. ?i dvd a"
    proof
      fix a assume a: "a \<in> set ys"
      obtain j where ys_j_a: "ys ! j = a" and jn: "j<?n" by (metis a in_set_conv_nth length_ys)
      have jP: "j < dim_row P" using jn P by auto
      have jQ: "j < dim_col Q" using jn Q by auto
      have "(P*?A*Q)$$(0,0) dvd (P*?A*Q)$$(j,j)"
        by (rule SNF_first_divides[OF SNF_PAQ], auto simp add: jP jQ)
      thus "ys ! 0 dvd a" using ys length_ys ys_j_a jn n0 by auto
    qed
    have "ideal_generated S = ideal_generated (set xs)" using set_xs by simp
    also have "... = ideal_generated (set ys)"
    proof
      show "ideal_generated (set xs) \<subseteq> ideal_generated (set ys)"
      proof (rule ideal_generated_subset2, rule ballI)
        fix b assume b: "b \<in> set xs"
        obtain i where b_A_ii: "b = ?A $$ (i,i)" and i_length: "i<length xs"
          using b set_xs_eq by auto
        obtain P' where inverts_mat_P': "inverts_mat P P' \<and> inverts_mat P' P"
          using inv_P unfolding invertible_mat_def by auto
        have P': "P' \<in> carrier_mat ?n ?n"
          using inverts_mat_P'
          unfolding carrier_mat_def inverts_mat_def
          by (auto,metis P carrier_matD index_mult_mat(3) one_carrier_mat)+
        obtain Q' where inverts_mat_Q': "inverts_mat Q Q' \<and> inverts_mat Q' Q"
          using inv_Q unfolding invertible_mat_def by auto
        have Q': "Q' \<in> carrier_mat ?n ?n"
          using inverts_mat_Q'
          unfolding carrier_mat_def inverts_mat_def
          by (auto,metis Q carrier_matD index_mult_mat(3) one_carrier_mat)+
        have rw_PAQ: "(P'*(P*?A*Q)*Q') $$ (i, i) = ?A $$ (i,i)"
          using inv_P'PAQQ'[OF A_carrier P _ _ Q P' Q'] inverts_mat_P' inverts_mat_Q' by auto
        have diag_PAQ: "isDiagonal_mat (P*?A*Q)"
          using SNF_PAQ unfolding Smith_normal_form_mat_def by auto
        have PAQ_carrier: "(P*?A*Q) \<in> carrier_mat ?n ?n" using P Q by auto
        obtain f where f: "(P'*(P*?A*Q)*Q') $$ (i, i) = (\<Sum>i\<in>set (diag_mat (P*?A*Q)). f i * i)"
          using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' i_length] by auto
        hence "?A $$ (i,i) = (\<Sum>i\<in>set (diag_mat (P*?A*Q)). f i * i)" unfolding rw_PAQ .
        thus "b\<in> ideal_generated (set ys)"
          unfolding ideal_explicit using set_ys_diag_mat b_A_ii by auto
      qed
      show "ideal_generated (set ys) \<subseteq> ideal_generated (set xs)"
      proof (rule ideal_generated_subset2, rule ballI)
        fix b assume b: "b \<in> set ys"
        have d: "distinct (diag_mat ?A)"
          by (metis (no_types, lifting) A_carrier card_distinct carrier_matD(1) diag_mat_def
             length_eq_card length_map map_nth set_xs set_xs_diag_mat)
        obtain i where b_PAQ_ii: "(P*?A*Q) $$ (i,i) = b" and i_length: "i<length xs" using b ys
          by (metis (no_types, lifting) in_set_conv_nth length_ys)
        obtain f where "(P * ?A * Q) $$ (i, i) = (\<Sum>i\<in>set (diag_mat ?A). f i * i)"
          using exists_f_PAQ_Aii[OF diag_A P _ Q i_length] by auto
        thus "b \<in> ideal_generated (set xs)"
          using b_PAQ_ii unfolding set_xs_diag_mat ideal_explicit by auto
      qed
    qed
    also have "... = ideal_generated (set ys - (set ys - {ys!0}))"
    proof (rule ideal_generated_dvd_eq_diff_set)
      show "?i \<in> set ys" using n0
        by (simp add: length_ys)
      show "?i \<notin> set ys - {?i}" by auto
      show "\<forall>j\<in>set ys - {?i}. ?i dvd j" using dvd_all by auto
      show "finite (set ys - {?i})" by auto
    qed
    also have "... = ideal_generated {?i}"
      by (metis Diff_cancel Diff_not_in insert_Diff insert_Diff_if length_ys n0 nth_mem)
    finally show "principal_ideal I" unfolding principal_ideal_def using ig_S by auto
  qed
qed

(*Alternative statement:*)
corollary diagonal_admits_SNF_imp_bezout_ring_JNF_alt:
  assumes admits_SNF: "\<forall>A. square_mat (A::'a mat) \<and> isDiagonal_mat A
\<longrightarrow> (\<exists>P Q. P \<in> carrier_mat (dim_row A) (dim_row A)
  \<and> Q \<in> carrier_mat (dim_row A) (dim_row A) \<and> invertible_mat P \<and> invertible_mat Q
  \<and> Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, rule allI, rule allI, rule impI)
  fix A::"'a mat" and n assume A: "A \<in> carrier_mat n n \<and> isDiagonal_mat A"
  have "square_mat A" using A by auto
  thus "\<exists>P Q. P \<in> carrier_mat n n \<and> Q \<in> carrier_mat n n
  \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat (P * A * Q)"
    using A admits_SNF by blast
qed

subsection \<open>Trying to transfer the @{text "\<Longrightarrow>"} implication to HA.\<close>

text \<open>We first hide some constants defined in @{text "Mod_Type_Connect"} in order to use the ones
presented in @{text "Perron_Frobenius.HMA_Connect"} by default.\<close>

context
  includes lifting_syntax
begin

lemma to_nat_mod_type_Bij_Nat:
  fixes a::"'n::mod_type"
  obtains b::'n where "mod_type_class.to_nat a = Bij_Nat.to_nat b"
  using Bij_Nat.to_nat_from_nat_id mod_type_class.to_nat_less_card by metis

lemma inj_on_Bij_nat_from_nat: "inj_on (Bij_Nat.from_nat::nat \<Rightarrow> 'a) {0..<CARD('a::finite)}"
  by (auto simp add: inj_on_def Bij_Nat.from_nat_def length_univ_list_card
      nth_eq_iff_index_eq univ_list(1))

text \<open>This lemma only holds if $a$ and $b$ have the same type. Otherwise,
  it is possible that @{text "Bij_Nat.to_nat a = Bij_Nat.to_nat b"}\<close>

lemma Bij_Nat_to_nat_neq:
  fixes a b ::"'n::mod_type"
  assumes "to_nat a \<noteq> to_nat b"
  shows "Bij_Nat.to_nat a \<noteq> Bij_Nat.to_nat b"
  using assms to_nat_inj by blast

text \<open>The following proof (a transfer rule for diagonal matrices)
  is weird, since it does not hold
  @{text "Bij_Nat.to_nat a = mod_type_class.to_nat a"}.

  At first, it seems possible to obtain the element $a'$ that satisfies
   @{text "Bij_Nat.to_nat a' = mod_type_class.to_nat a"} and then continue with the proof, but then
  we cannot prove @{text "HMA_I (Bij_Nat.to_nat a') a"}.

  This means that we must use the previous lemma @{text "Bij_Nat_to_nat_neq"}, but this imposes the
  matrix to be square.
  \<close>

lemma HMA_isDiagonal[transfer_rule]: "(HMA_M ===> (=))
  isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'n::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy [transfer_rule] = "1"
  have "y $h a $h b = 0"
    if all0: "\<forall>i j. i \<noteq> j \<and> i < dim_row x \<and> j < dim_col x \<longrightarrow> x $$ (i, j) = 0"
      and a_noteq_b: "a \<noteq> b" for a::'n and b::'n
  proof -
    have "to_nat a \<noteq> to_nat b" using a_noteq_b by auto
    hence distinct: "Bij_Nat.to_nat a \<noteq> Bij_Nat.to_nat b" by (rule Bij_Nat_to_nat_neq)
    moreover have "Bij_Nat.to_nat a < dim_row x" and "Bij_Nat.to_nat b < dim_col x"
      using Bij_Nat.to_nat_less_card dim_row_transfer_rule rel_xy dim_col_transfer_rule
      by fastforce+
    ultimately have b: "x $$ (Bij_Nat.to_nat a, Bij_Nat.to_nat b) = 0" using all0 by auto
    have [transfer_rule]: "HMA_I (Bij_Nat.to_nat a) a" by (simp add: HMA_I_def)
    have [transfer_rule]: "HMA_I (Bij_Nat.to_nat b) b" by (simp add: HMA_I_def)
    have "index_hma y a b = 0" using b by (transfer', auto)
    thus ?thesis unfolding index_hma_def .
  qed
  moreover have "x $$ (i, j) = 0"
    if all0: "\<forall>a b. a \<noteq> b \<longrightarrow> y $h a $h b = 0"
      and ij: "i \<noteq> j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
  proof -
    have i_n: "i < CARD('n)" and j_n: "j < CARD('n)"
      using i j rel_xy dim_row_transfer_rule dim_col_transfer_rule
      by fastforce+
    let ?i' = "Bij_Nat.from_nat i::'n"
    let ?j' = "Bij_Nat.from_nat j::'n"
    have i'_neq_j': "?i' \<noteq> ?j'" using ij i_n j_n Bij_Nat.from_nat_inj by blast
    hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto
    have [transfer_rule]: "HMA_I i ?i'" unfolding HMA_I_def
      by (simp add: Bij_Nat.to_nat_from_nat_id i_n)
    have [transfer_rule]: "HMA_I j ?j'" unfolding HMA_I_def
      by (simp add: Bij_Nat.to_nat_from_nat_id j_n)
    show ?thesis using y0 by (transfer, auto)
  qed
  ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
    by auto
qed

text \<open>Indeed, we can prove the transfer rules with the new connection based on the
  @{text "mod_type"} class, which was developed in the  @{text "Mod_Type_Connect"} file\<close>

text \<open>This is the same lemma as the one presented above, but now using the @{text "to_nat"} function
  defined in the  @{text "mod_type"} class and then we can prove it for non-square matrices,
  which is very useful since our algorithms are not restricted to square matrices.\<close>

lemma HMA_isDiagonal_Mod_Type[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=))
  isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'m::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy [transfer_rule] = "1"
  have "y $h a $h b = 0"
    if all0: "\<forall>i j. i \<noteq> j \<and> i < dim_row x \<and> j < dim_col x \<longrightarrow> x $$ (i, j) = 0"
      and a_noteq_b: "to_nat a \<noteq> to_nat b" for a::'m and b::'n
  proof -
    have distinct: "to_nat a \<noteq> to_nat b" using a_noteq_b by auto
    moreover have "to_nat a < dim_row x" and "to_nat b < dim_col x"
      using to_nat_less_card rel_xy
      using Mod_Type_Connect.dim_row_transfer_rule Mod_Type_Connect.dim_col_transfer_rule
      by fastforce+
    ultimately have b: "x $$ (to_nat a, to_nat b) = 0" using all0 by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have "index_hma y a b = 0" using b by (transfer', auto)
    thus ?thesis unfolding index_hma_def .
  qed
  moreover have "x $$ (i, j) = 0"
    if all0: "\<forall>a b. to_nat a \<noteq> to_nat b \<longrightarrow> y $h a $h b = 0"
      and ij: "i \<noteq> j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
  proof -
    have i_n: "i < CARD('m)"
      using i rel_xy by (simp add: Mod_Type_Connect.dim_row_transfer_rule)
    have j_n: "j < CARD('n)"
      using j rel_xy by (simp add: Mod_Type_Connect.dim_col_transfer_rule)
    let ?i' = "from_nat i::'m"
    let ?j' = "from_nat j::'n"
    have "to_nat ?i' \<noteq> to_nat ?j'"
      by (simp add: i_n ij j_n mod_type_class.to_nat_from_nat_id)
    hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: to_nat_from_nat_id i_n)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'"
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: to_nat_from_nat_id j_n)
    show ?thesis using y0 by (transfer, auto)
  qed
  ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
    by auto
qed

(*We cannot state:

 lemma HMA_SNF[transfer_rule]: "(HMA_M ===> (=)) Smith_normal_form_mat
  (Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}\<Rightarrow>bool)"

Since we need properties about Suc (Bij_Nat.to_nat a). This means that is mandatory to use
a bridge that relates the JNF representation with the HA one based on indexes with the mod_type
class restriction. This is carried out in the file Mod_Type_Connect.

Otherwise, I cannot relate

x $$ (to_nat a, to_nat a) dvd x $$ (to_nat (a + 1), to_nat (a + 1))

with

y $h a $h a dvd y $h (a + 1) $h (a + 1)

being such to_nat the one presented in Mod_Type, which is not the same as Bij_Nat.to_nat
(mod_type_class.to_nat satisfies more properties that easier the definitions and proofs,
and indeed are fundamental for defining the Smith normal form).
*)

text\<open>We state the transfer rule using the relations developed in the new bride of the file
    @{text "Mod_Type_Connect"}.\<close>

lemma HMA_SNF[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) Smith_normal_form_mat
(Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'m::{mod_type}\<Rightarrow>bool)"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have "y $h a $h b dvd y $h (a + 1) $h (b + 1)"
    if SNF_condition: "\<forall>a. Suc a < dim_row x \<and> Suc a < dim_col x
      \<longrightarrow> x $$ (a, a) dvd x $$ (Suc a, Suc a)"
      and a1: "Suc (to_nat a) < nrows y" and a2: "Suc (to_nat b) < ncols y"
      and ab: "to_nat a = to_nat b" for a::'m and b::'n
  proof -
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (a+1)) (a+1)"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (b+1)) (b+1)"
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have "Suc (to_nat a) < dim_row x" using a1
      by (metis Mod_Type_Connect.dim_row_transfer_rule nrows_def rel_xy)
    moreover have "Suc (to_nat b) < dim_col x"
      by (metis Mod_Type_Connect.dim_col_transfer_rule a2 ncols_def rel_xy)
    ultimately have "x $$ (to_nat a, to_nat b) dvd x $$ (Suc (to_nat a), Suc (to_nat b))"
      using SNF_condition by (simp add: ab)
    also have "... = x $$ (to_nat (a+1), to_nat (b+1))"
      by (metis Suc_eq_plus1 a1 a2 nrows_def ncols_def to_nat_suc)
    finally have SNF_cond: "x $$ (to_nat a, to_nat b) dvd x $$ (to_nat (a + 1), to_nat (b + 1))" .
    have "x $$ (to_nat a, to_nat b) = index_hma y a b" by (transfer, simp)
    moreover have "x $$ (to_nat (a + 1), to_nat (b + 1)) = index_hma y (a+1) (b+1)"
      by (transfer, simp)
    ultimately show ?thesis using SNF_cond unfolding index_hma_def by auto
  qed
  moreover have  "x $$ (a, a) dvd x $$ (Suc a, Suc a)"
    if SNF: "\<forall>a b. to_nat a = to_nat b \<and> Suc (to_nat a) < nrows y \<and> Suc (to_nat b) < ncols y
        \<longrightarrow> y $h a $h b dvd y $h (a + 1) $h (b + 1)"
      and a1: "Suc a < dim_row x" and a2: "Suc a < dim_col x" for a
  proof -
    have dim_row_CARD: "dim_row x = CARD('m)"
      using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
    have dim_col_CARD: "dim_col x = CARD('n)"
      using Mod_Type_Connect.dim_col_transfer_rule rel_xy by blast
    let ?a' = "from_nat a::'m"
    let ?b' = "from_nat a::'n"
    have Suc_a_less_CARD: "a + 1 < CARD('m)" using a1 dim_row_CARD by auto
    have Suc_b_less_CARD: "a + 1 < CARD('n)" using a2
      by (metis Mod_Type_Connect.dim_col_transfer_rule Suc_eq_plus1 rel_xy)
    have aa'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?a'"
      unfolding Mod_Type_Connect.HMA_I_def
      by (metis Suc_a_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?a' + 1)"
      unfolding Mod_Type_Connect.HMA_I_def
      unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_a_less_CARD] by auto
    have ab'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?b'"
      unfolding Mod_Type_Connect.HMA_I_def
      by (metis Suc_b_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?b' + 1)"
      unfolding Mod_Type_Connect.HMA_I_def
      unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_b_less_CARD] by auto
    have aa'1: "a = to_nat ?a'" using aa' by (simp add: Mod_Type_Connect.HMA_I_def)
    have ab'1: "a = to_nat ?b'" using ab' by (simp add: Mod_Type_Connect.HMA_I_def)
    have "Suc (to_nat ?a') < nrows y" using a1 dim_row_CARD
      by (simp add: mod_type_class.to_nat_from_nat_id nrows_def)
    moreover have "Suc (to_nat ?b') < ncols y" using a2 dim_col_CARD
      by (simp add: mod_type_class.to_nat_from_nat_id ncols_def)
    ultimately have SNF': "y $h ?a' $h ?b' dvd y $h (?a' + 1) $h (?b' + 1)"
      using SNF ab'1 aa'1 by auto
     have "index_hma y ?a' ?b' = x $$ (a, a)" by (transfer, simp)
     moreover have "index_hma y (?a'+1) (?b'+1) = x $$ (a+1, a+1)" by (transfer, simp)
     ultimately show ?thesis using SNF' unfolding index_hma_def by auto
  qed
  ultimately show ?case unfolding Smith_normal_form_mat_def Smith_normal_form_def
    using rel_xy by (auto) (transfer', auto)+
qed

lemma HMA_admits_SNF [transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n::{mod_type} ^ 'n::{mod_type} \<Rightarrow> _) ===> (=))
  admits_SNF_JNF admits_SNF_HA"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note [transfer_rule] = this
  hence id: "dim_row x = CARD('n)" by (auto simp: Mod_Type_Connect.HMA_M_def)
  then show ?case unfolding admits_SNF_JNF_def admits_SNF_HA_def
    by (transfer, auto, metis "1" Mod_Type_Connect.dim_col_transfer_rule)
qed
end

(*If the following result holds, then I will get the result.

  But the theorem is false, since the assumption fixes the type 'n (within the proof is not
  arbitrary any more). We cannot quantify over type variables in Isabelle/HOL.*)

(*
lemma diagonal_admits_SNF_imp_bezout_ring_JNF3:
  assumes admits_SNF: "\<forall>A. (A::'a mat) \<in> carrier_mat (CARD('n)) (CARD('n)) \<and> isDiagonal_mat A
\<longrightarrow> (\<exists>P Q. P \<in> carrier_mat (dim_row A) (dim_row A)
  \<and> Q \<in> carrier_mat (dim_row A) (dim_row A) \<and> invertible_mat P \<and> invertible_mat Q
  \<and> Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  apply (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto)
*)

text\<open>Here we have a problem when trying to apply local type definitions\<close>
(*
Once the assumption is translated to JNF, we get that it holds for all matrices with
CARD('n) rows and CARD('n) columns. That is, we do not have the result for any matrix, just
for matrices of such dimensions (within the proof, the type 'n is not arbitrary, is fixed).
*)
lemma diagonal_admits_SNF_imp_bezout_ring:
  assumes admits_SNF: "\<forall>A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A
    \<longrightarrow> (\<exists>P Q. invertible (P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})
        \<and> invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})
        \<and> Smith_normal_form (P**A**Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto)
  fix A::"'a mat" and n
    assume A: "A \<in> carrier_mat n n" and diag_A: "isDiagonal_mat A"
  have a: "\<forall>A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
    using admits_SNF unfolding admits_SNF_HA_def .
  have JNF: "\<forall>(A::'a mat)\<in> carrier_mat CARD('n) CARD('n). admits_SNF_JNF A"
  (*We can get this result, but this does not imply that it holds for any n \<times> n matrix, just
    for the concrete case that n = CARD('n). Within this proof, we cannot apply local type
    definitions, since the 'n is not an schematic variable any more, it is fixed.*)
  proof
    fix A::"'a mat"
    assume A: "A \<in> carrier_mat CARD('n) CARD('n)"
    let ?B = "(Mod_Type_Connect.to_hma\<^sub>m  A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})"
    have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?B"
      using A unfolding Mod_Type_Connect.HMA_M_def by auto
    have b: "admits_SNF_HA ?B" using a by auto
    show "admits_SNF_JNF A" using b by transfer
  qed
  (*Here we cannot apply local type definitions (either cancel_card_constraint or
  cancel_type_definition) to thm JNF*)
  thus "\<exists>P. P \<in> carrier_mat n n \<and>
             (\<exists>Q. Q \<in> carrier_mat n n \<and> invertible_mat P
        \<and> invertible_mat Q \<and> Smith_normal_form_mat (P * A * Q))"
    using JNF A diag_A unfolding admits_SNF_JNF_def unfolding square_mat.simps oops

text\<open>This means that the @{text "\<Longrightarrow>"}  implication cannot be proven in HA, since we cannot quantify
over type variables in Isabelle/HOL. We then prove both implications in JNF.\<close>

subsection \<open>Transfering the @{text "\<Longleftarrow>"} implication from HA to JNF using transfer rules
  and local type definitions\<close>

(*
  I need to transfer the theorem bezout_ring_imp_diagonal_admits_SNF (stated in HA) to JNF.
  The first necessary step is to prove transfer rules to connect matrices in HA (when the type
  of the indexes must be mod_type). The original connection HMA_Connect presented in the
  Perron--Frobenius development just connects matrices of type 'a^'b::finite^'c::finite with
  the corresponding ones in JNF, but I need to transfer theorems with matrices of type:
  'a^'b::mod_type^'c::mod_type.

  The file that allows this bridge is Mod_Type_Connect.

  Once that step is carried out, I would have to transfer the result by means of the lifting
  and transfer package and then apply local type definitions to get rid of the type (that is,
  to change CARD('n) by an arbitrary n).

  The usual approach consists of applying lifting and transfer to the theorem, and then we
  obtain a fact like

          A \<in> carrier_mat (CARD('n::mod_type)) (CARD('n::mod_type))

  When trying to apply local type definitions (to substitute CARD('n::mod_type) by n), then
  I would have to apply interalize_sort and then proving the restriction class.mod_type (together
  with the operations associated to that class). Since the mod_type class already introduced
  several type restrictions (times, neg_numeral_well_order), operations (+,-) and constants (1,0),
  this means that we have to proceed using dictionary construction. We would have to define
  a mod_type with explicit operations, to get 'a only of type 'a::type.

  definition "mod_type_with n (tms::'a\<Rightarrow>'a\<Rightarrow>'a) mns pls zr umns (one'::'a)
        (less_eq'::'a\<Rightarrow>'a\<Rightarrow>bool) (less'::'a\<Rightarrow>'a\<Rightarrow>bool) (Rep_op::'a\<Rightarrow>int) (Abs_op::int\<Rightarrow>'a)
      \<equiv> (type_definition Rep_op Abs_op {0..<n} \<and>  1 < n
      \<and> (zr = Abs_op 0)
      \<and> (one' = Abs_op 1)
      \<and> (\<forall>x y. pls x y = Abs_op (((Rep_op x) + (Rep_op y)) mod (n)))
      \<and> (\<forall>x y. tms x y = Abs_op (((Rep_op x) * (Rep_op y)) mod (n)))
      \<and> (\<forall>x y. mns x y = Abs_op (((Rep_op x) - (Rep_op y)) mod (n)))
      \<and> (\<forall>x. umns x = Abs_op ((- (Rep_op x)) mod (n)))
      \<and> (\<forall>x y. less' x y \<longrightarrow> (Rep_op x) < (Rep_op y))
      \<and> class.neg_numeral mns pls zr umns
      \<and> class.wellorder less_eq' less')"

  Once this is completed, I would have to connect mod_type and mod_type_with,
  prove new transfer rules and so on. This is the usual approach and has been successfully applied,
  for instance, by Fabian Immler to transform a (type based) library of linear algebra into another
  one with explicit carriers.

  Fortunately, in this case there is a shortcut: we can use the type 'a mod_ring from the
  Berlekamp--Zassenhaus development to express the lemma in HA
  (thm bezout_ring_imp_diagonal_admits_SNF) using that type (the type 'a mod_ring is an instance
  of the mod_type class, and then is a particular case).

  This means that any lemma that has a matrix of type 'a^'b::mod_type^'c^'mod_type can be expressed
  as 'a^'b mod_ring^'c mod_ring, where 'b and 'c must satisfy the nontriv restriction
  (they must have more than one element).

  This is done in the file Finite_Field_Mod_Type_Connection, which shows that 'a mod_ring is an
  instance of the mod_type class.

  This type 'a mod_ring has a very useful property: CARD('b mod_ring) = CARD('b)
  This means that it is very easy to apply local type definitions. The problematic fact
  would then be transformed to:

      A \<in> carrier_mat (CARD('n::nontriv)) (CARD('n::nontriv)).

  It is very easy to apply local type definitions to this fact, since it is very easy to get rid
  of the nontriv restriction (on the contrary, the mod_type restriction was quite hard).

*)

(*
  In our concrete case: we write the theorem in terms of the mod_ring type thanks to
  the file Finite_Field_Mod_Type_Connection.

  With this type 'n::nontriv mod_ring I can easily apply local type definitions, since we
  will get CARD(?'n::nontriv).
*)

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring:
  assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  shows "\<forall>A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. isDiagonal A
    \<longrightarrow> (\<exists>P Q.
        invertible (P::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) \<and>
        invertible (Q::'a^'n::nontriv mod_ring^'n::nontriv mod_ring) \<and>
        Smith_normal_form (P**A**Q))"
  using bezout_ring_imp_diagonal_admits_SNF[OF assms] by auto

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits:
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*It is equivalent to the statement based on OFCLASS*)
  shows "\<forall>A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. admits_SNF_HA A"
  using bezout_ring_imp_diagonal_admits_SNF
        [OF Rings2.class.Rings2.bezout_ring.of_class.intro[OF of]]
  unfolding admits_SNF_HA_def by auto

text\<open>I start here to apply local type definitions\<close>

context
  fixes p::nat
  assumes local_typedef: "\<exists>(Rep :: ('b \<Rightarrow> int)) Abs. type_definition Rep Abs {0..<p :: int}"
  and p: "p>1"
begin

lemma type_to_set:
  shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b \<Rightarrow> int)" and Abs
    where t: "type_definition Rep Abs {0..<p :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<p}" using t type_definition.card by fastforce
  also have "... = p" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed

text\<open>I transfer the lemma from HA to JNF, substituting @{text "CARD('n)"} by $p$.
  I apply @{text "internalize-sort"} to @{text "'n"} and get rid of
  the @{text "nontriv"} restriction.\<close>

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux:
  assumes "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "Ball {A::'a::comm_ring_1 mat. A \<in> carrier_mat p p} admits_SNF_JNF"
  using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits[untransferred, unfolded CARD_mod_ring,
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by auto
end

text\<open>The @{text "\<Longleftarrow>"} implication in JNF\<close>

text\<open>Since @{text "nontriv"} imposes the type to have more than one element,
  the cases $n=0$ (@{text "A \<in> carrier_mat 0 0"}) and $n = 1$ (@{text "A \<in> carrier_mat 1 1"})
  must be treated separately.\<close>

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2:
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "\<forall>(A::'a mat)\<in>carrier_mat n n. admits_SNF_JNF A"
proof (cases "n = 0")
  case True
  show ?thesis
    by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def
        Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, fastforce)
next
  case False note not0 = False
  show ?thesis
  proof (cases "n=1")
  case True
  show ?thesis
    by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def
        Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, auto)
       (metis dvd_1_left index_one_mat(2) index_one_mat(3) less_Suc0 nat_dvd_not_less
        right_mult_one_mat' zero_less_Suc)
  next
    case False
    then have "n>1" using not0 by auto
    then show ?thesis (*Here I apply the local type definition rule, to cancel the type*)
      using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux[cancel_type_definition, of n] of
      by auto
  qed
qed

text \<open>Alternative statements\<close>

lemma bezout_ring_imp_diagonal_admits_SNF_JNF:
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "\<forall>A::'a mat. admits_SNF_JNF A"
proof
  fix A::"'a mat"
  have "A\<in> carrier_mat (dim_row A) (dim_col A)" unfolding carrier_mat_def by auto
  thus "admits_SNF_JNF A"
    using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2[OF of]
    by (metis admits_SNF_JNF_def square_mat.elims(2))
qed

lemma admits_SNF_JNF_alt_def:
  "(\<forall>A::'a::comm_ring_1 mat. admits_SNF_JNF A)
  = (\<forall>A n. (A::'a mat) \<in> carrier_mat n n \<and> isDiagonal_mat A
  \<longrightarrow> (\<exists>P Q. P \<in> carrier_mat n n \<and> Q \<in> carrier_mat n n \<and> invertible_mat P \<and> invertible_mat Q
      \<and> Smith_normal_form_mat (P*A*Q)))" (is "?a = ?b")
  by (auto simp add: admits_SNF_JNF_def, metis carrier_matD(1) carrier_matD(2), blast)

subsection \<open>Final theorem in JNF\<close>
text \<open>Final theorem using @{text "class.bezout_ring"}\<close>

theorem diagonal_admits_SNF_iff_bezout_ring:
  shows "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus
  \<longleftrightarrow> (\<forall>A::'a mat. admits_SNF_JNF A)" (is "?a \<longleftrightarrow> ?b")
proof
  assume ?a
  thus ?b using bezout_ring_imp_diagonal_admits_SNF_JNF by auto
next
  assume b: ?b
  have rw: "\<forall>A n. (A::'a mat) \<in> carrier_mat n n \<and> isDiagonal_mat A \<longrightarrow>
          (\<exists>P Q. P \<in> carrier_mat n n \<and> Q \<in> carrier_mat n n \<and> invertible_mat P
          \<and> invertible_mat Q \<and> Smith_normal_form_mat (P * A * Q))"
    using admits_SNF_JNF_alt_def b by auto
  show ?a
    using diagonal_admits_SNF_imp_bezout_ring_JNF[OF rw]
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
    by auto
qed

text \<open>Final theorem using @{text "OFCLASS"}\<close>

theorem diagonal_admits_SNF_iff_bezout_ring':
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class) \<equiv> (\<And>A::'a mat. admits_SNF_JNF A)"
proof
  fix A::"'a mat"
  assume a: "OFCLASS('a, bezout_ring_class)"
  show "admits_SNF_JNF A"
    using OFCLASS_bezout_ring_imp_class_bezout_ring[OF a] diagonal_admits_SNF_iff_bezout_ring
    by auto
next
  assume "(\<And>A::'a mat. admits_SNF_JNF A)"
  hence *: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus"
    using diagonal_admits_SNF_iff_bezout_ring by auto
  show "OFCLASS('a, bezout_ring_class)"
    by (rule Rings2.class.Rings2.bezout_ring.of_class.intro, rule *)
qed

end