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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory Submission
  imports Defs
begin

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip:         "(SKIP,s) \<Rightarrow> s" |
Assign:       "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq:          "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue:       "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse:      "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse:   "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:    "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
OrLeft:       "\<lbrakk> (c\<^sub>1,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2,s) \<Rightarrow> s'" |
OrRight:      "\<lbrakk> (c\<^sub>2,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2,s) \<Rightarrow> s'" |
Assume:       "bval b s \<Longrightarrow> (ASSUME b, s) \<Rightarrow> s" |
LoopBreak:    "(LOOP c,s) \<Rightarrow> s" |
LoopContinue: "\<lbrakk> (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (LOOP c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (LOOP c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

declare big_step.intros [intro]
lemmas big_step_induct = big_step.induct[split_format(complete)]

inductive_cases skipE[elim!]: "(SKIP,s) \<Rightarrow> t"
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases OrE: "(c1 OR c2,s1) \<Rightarrow> s3"
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
inductive_cases LoopE: "(LOOP c, s) \<Rightarrow> t"

type_synonym com_den = "(state \<times> state) set"

definition W :: "(state \<Rightarrow> bool) \<Rightarrow> com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
  "W db dc = (\<lambda>dw. {(s,t). if db s then (s,t) \<in> dc O dw else s=t})"

definition L :: "com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
  "L dc = (\<lambda>dl. {(s,t). (s,t) \<in> dc O dl} \<union> Id)"

fun D :: "com \<Rightarrow> com_den" where
"D SKIP   = Id" |
"D (x ::= a) = {(s,t). t = s(x := aval a s)}" |
"D (c1;;c2)  = D(c1) O D(c2)" |
"D (IF b THEN c1 ELSE c2)
 = {(s,t). if bval b s then (s,t) \<in> D c1 else (s,t) \<in> D c2}" |
"D (WHILE b DO c) = lfp (W (bval b) (D c))" |
"D (c1 OR c2) = (D c1) \<union> (D c2)" |
"D (ASSUME b) = {(s,t). bval b s \<and> s = t}" |
"D (LOOP c) = lfp (L (D c))"

lemma W_mono: "mono (W b r)"
by (unfold W_def mono_def) auto

lemma D_While_If:
  "D(WHILE b DO c) = D(IF b THEN c;;WHILE b DO c ELSE SKIP)"
proof-
  let ?w = "WHILE b DO c" let ?f = "W (bval b) (D c)"
  have "D ?w = lfp ?f" by simp
  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF W_mono])
  also have "\<dots> = D(IF b THEN c;;?w ELSE SKIP)" by (simp add: W_def)
  finally show ?thesis .
qed

thm lfp_unfold

lemma L_mono: "mono (L c)"
  by (unfold L_def mono_def) auto

lemma D_Loop_absorb: "D (Loop c) = D (c;;Loop c) \<union> Id"
proof-
  let ?l = "Loop c" let ?f = "L (D c)"
  have "D ?l = lfp ?f" by simp
  also have "... = ?f (lfp ?f)" by(rule lfp_unfold [OF L_mono])
  also have "... = D c O D ?l \<union> Id" by(simp add: L_def)
  also have "... = D (c;;?l) \<union> Id" by simp
  finally show ?thesis .
qed

lemma D_if_big_step:  "(c,s) \<Rightarrow> t \<Longrightarrow> (s,t) \<in> D(c)"
proof (induction rule: big_step_induct)
  case WhileFalse
  with D_While_If show ?case by auto
next
  case WhileTrue
  show ?case unfolding D_While_If using WhileTrue by auto
next
  case (LoopBreak c s)
  then have "D (LOOP c) = lfp (L (D c))" by simp
  then have "Id \<subseteq> lfp (L (D c))"
    using L_def Un_subset_iff lfp_greatest
    by (metis (no_types, lifting))
  then show ?case
    by (simp add: in_mono)
next
  case (LoopContinue c s\<^sub>1 s\<^sub>2 s\<^sub>3)
  show ?case unfolding D_Loop_absorb using LoopContinue by auto
qed auto

abbreviation Big_step :: "com \<Rightarrow> com_den" where
"Big_step c \<equiv> {(s,t). (c,s) \<Rightarrow> t}"

lemma Big_step_if_D:  "(s,t) \<in> D(c) \<Longrightarrow> (s,t) \<in> Big_step c"
proof (induction c arbitrary: s t)
  case Seq thus ?case by fastforce
next
  case (While b c)
  let ?B = "Big_step (WHILE b DO c)" let ?f = "W (bval b) (D c)"
  have "?f ?B \<subseteq> ?B" using While.IH by (auto simp: W_def)
  from lfp_lowerbound[where ?f = "?f", OF this] While.prems
  show ?case by auto
next
  case (ASSUME b)
  show ?case
    using ASSUME by auto
next
  case (Loop c)
  let ?B = "Big_step (LOOP c)" let ?f = "L (D c)"
  have "?f ?B \<subseteq> ?B" using Loop.IH by (auto simp: L_def)
  from lfp_lowerbound[where ?f = "?f", OF this] Loop.prems
  show ?case by auto
qed (auto split: if_splits)

theorem denotational_is_big_step:
  "(s,t) \<in> D(c)  =  ((c,s) \<Rightarrow> t)"
by (metis D_if_big_step Big_step_if_D[simplified])

end


(*  Title:      HOL/Library/Lattice_Constructions.thy
    Author:     Lukas Bulwahn
    Copyright   2010 TU Muenchen
*)

theory Lattice_Constructions
imports Main
begin

subsection {* Values extended by a bottom element *}

datatype 'a bot = Value 'a | Bot

instantiation bot :: (preorder) preorder
begin

definition less_eq_bot where
  "x \<le> y \<longleftrightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> x \<le> y))"

definition less_bot where
  "x < y \<longleftrightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> x < y))"

lemma less_eq_bot_Bot [simp]: "Bot \<le> x"
  by (simp add: less_eq_bot_def)

lemma less_eq_bot_Bot_code [code]: "Bot \<le> x \<longleftrightarrow> True"
  by simp

lemma less_eq_bot_Bot_is_Bot: "x \<le> Bot \<Longrightarrow> x = Bot"
  by (cases x) (simp_all add: less_eq_bot_def)

lemma less_eq_bot_Value_Bot [simp, code]: "Value x \<le> Bot \<longleftrightarrow> False"
  by (simp add: less_eq_bot_def)

lemma less_eq_bot_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
  by (simp add: less_eq_bot_def)

lemma less_bot_Bot [simp, code]: "x < Bot \<longleftrightarrow> False"
  by (simp add: less_bot_def)

lemma less_bot_Bot_is_Value: "Bot < x \<Longrightarrow> \<exists>z. x = Value z"
  by (cases x) (simp_all add: less_bot_def)

lemma less_bot_Bot_Value [simp]: "Bot < Value x"
  by (simp add: less_bot_def)

lemma less_bot_Bot_Value_code [code]: "Bot < Value x \<longleftrightarrow> True"
  by simp

lemma less_bot_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
  by (simp add: less_bot_def)

instance proof
qed (auto simp add: less_eq_bot_def less_bot_def less_le_not_le elim: order_trans split: bot.splits)

end

instance bot :: (order) order proof
qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)

instance bot :: (linorder) linorder proof
qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)

instantiation bot :: (order) bot
begin

definition "bot = Bot"

instance ..

end

instantiation bot :: (top) top
begin

definition "top = Value top"

instance ..

end

instantiation bot :: (semilattice_inf) semilattice_inf
begin

definition inf_bot
where
  "inf x y = (case x of Bot => Bot | Value v => (case y of Bot => Bot | Value v' => Value (inf v v')))"

instance proof
qed (auto simp add: inf_bot_def less_eq_bot_def split: bot.splits)

end

instantiation bot :: (semilattice_sup) semilattice_sup
begin

definition sup_bot
where
  "sup x y = (case x of Bot => y | Value v => (case y of Bot => x | Value v' => Value (sup v v')))"

instance proof
qed (auto simp add: sup_bot_def less_eq_bot_def split: bot.splits)

end

instance bot :: (lattice) bounded_lattice_bot
by(intro_classes)(simp add: bot_bot_def)

section {* Values extended by a top element *}

datatype 'a top = Value 'a | Top

instantiation top :: (preorder) preorder
begin

definition less_eq_top where
  "x \<le> y \<longleftrightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> x \<le> y))"

definition less_top where
  "x < y \<longleftrightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> x < y))"

lemma less_eq_top_Top [simp]: "x <= Top"
  by (simp add: less_eq_top_def)

lemma less_eq_top_Top_code [code]: "x \<le> Top \<longleftrightarrow> True"
  by simp

lemma less_eq_top_is_Top: "Top \<le> x \<Longrightarrow> x = Top"
  by (cases x) (simp_all add: less_eq_top_def)

lemma less_eq_top_Top_Value [simp, code]: "Top \<le> Value x \<longleftrightarrow> False"
  by (simp add: less_eq_top_def)

lemma less_eq_top_Value_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
  by (simp add: less_eq_top_def)

lemma less_top_Top [simp, code]: "Top < x \<longleftrightarrow> False"
  by (simp add: less_top_def)

lemma less_top_Top_is_Value: "x < Top \<Longrightarrow> \<exists>z. x = Value z"
  by (cases x) (simp_all add: less_top_def)

lemma less_top_Value_Top [simp]: "Value x < Top"
  by (simp add: less_top_def)

lemma less_top_Value_Top_code [code]: "Value x < Top \<longleftrightarrow> True"
  by simp

lemma less_top_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
  by (simp add: less_top_def)

instance proof
qed (auto simp add: less_eq_top_def less_top_def less_le_not_le elim: order_trans split: top.splits)

end

instance top :: (order) order proof
qed (auto simp add: less_eq_top_def less_top_def split: top.splits)

instance top :: (linorder) linorder proof
qed (auto simp add: less_eq_top_def less_top_def split: top.splits)

instantiation top :: (order) top
begin

definition "top = Top"

instance ..

end

instantiation top :: (bot) bot
begin

definition "bot = Value bot"

instance ..

end

instantiation top :: (semilattice_inf) semilattice_inf
begin

definition inf_top
where
  "inf x y = (case x of Top => y | Value v => (case y of Top => x | Value v' => Value (inf v v')))"

instance proof
qed (auto simp add: inf_top_def less_eq_top_def split: top.splits)

end

instantiation top :: (semilattice_sup) semilattice_sup
begin

definition sup_top
where
  "sup x y = (case x of Top => Top | Value v => (case y of Top => Top | Value v' => Value (sup v v')))"

instance proof
qed (auto simp add: sup_top_def less_eq_top_def split: top.splits)

end

instance top :: (lattice) bounded_lattice_top
by(intro_classes)(simp add: top_top_def)

subsection {* Values extended by a top and a bottom element *}

datatype 'a flat_complete_lattice = Value 'a | Bot | Top

instantiation flat_complete_lattice :: (type) order
begin

definition less_eq_flat_complete_lattice where
  "x \<le> y == (case x of Bot => True | Value v1 => (case y of Bot => False | Value v2 => (v1 = v2) | Top => True) | Top => (y = Top))"

definition less_flat_complete_lattice where
  "x < y = (case x of Bot => \<not> (y = Bot) | Value v1 => (y = Top) | Top => False)"

lemma [simp]: "y <= Top"
unfolding less_eq_flat_complete_lattice_def by (auto split: flat_complete_lattice.splits)

lemma greater_than_two_values:
  assumes "a ~= aa" "Value a <= z" "Value aa <= z"
  shows "z = Top"
using assms
by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)

lemma lesser_than_two_values:
  assumes "a ~= aa" "z <= Value a" "z <= Value aa"
  shows "z = Bot"
using assms
by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)

instance proof
qed (auto simp add: less_eq_flat_complete_lattice_def less_flat_complete_lattice_def split: flat_complete_lattice.splits)

end

instantiation flat_complete_lattice :: (type) bot
begin

definition "bot = Bot"

instance ..

end

instantiation flat_complete_lattice :: (type) top
begin

definition "top = Top"

instance ..

end

instantiation flat_complete_lattice :: (type) lattice
begin

definition inf_flat_complete_lattice
where
  "inf x y = (case x of Bot => Bot | Value v1 => (case y of Bot => Bot | Value v2 => if (v1 = v2) then x else Bot | Top => x) | Top => y)"

definition sup_flat_complete_lattice
where
  "sup x y = (case x of Bot => y | Value v1 => (case y of Bot => x | Value v2 => if v1 = v2 then x else Top | Top => Top) | Top => Top)"

instance proof
qed (auto simp add: inf_flat_complete_lattice_def sup_flat_complete_lattice_def less_eq_flat_complete_lattice_def split: flat_complete_lattice.splits)

end

instantiation flat_complete_lattice :: (type) complete_lattice
begin

definition Sup_flat_complete_lattice
where
  "Sup A = (if (A = {} \<or> A = {Bot}) then Bot else (if (\<exists> v. A - {Bot} = {Value v}) then Value (THE v. A - {Bot} = {Value v}) else Top))"

definition Inf_flat_complete_lattice
where
  "Inf A = (if (A = {} \<or> A = {Top}) then Top else (if (\<exists> v. A - {Top} = {Value v}) then Value (THE v. A - {Top} = {Value v}) else Bot))"

instance
proof
  fix x A
  assume "(x :: 'a flat_complete_lattice) : A"
  {
    fix v
    assume "A - {Top} = {Value v}"
    from this have "(THE v. A - {Top} = {Value v}) = v"
      by (auto intro!: the1_equality)
    moreover
    from `x : A` `A - {Top} = {Value v}` have "x = Top \<or> x = Value v"
      by auto
    ultimately have "Value (THE v. A - {Top} = {Value v}) <= x"
      by auto
  }
  from `x : A` this show "Inf A <= x"
    unfolding Inf_flat_complete_lattice_def
    by fastforce
next
  fix z A
  assume z: "\<And>x. x : A ==> z <= (x :: 'a flat_complete_lattice)"
  {
    fix v
    assume "A - {Top} = {Value v}"
    moreover
    from this have "(THE v. A - {Top} = {Value v}) = v"
      by (auto intro!: the1_equality)
    moreover
    note z
    moreover
    ultimately have "z <= Value (THE v::'a. A - {Top} = {Value v})"
      by auto
  } moreover
  {
    assume not_one_value: "A ~= {}" "A ~= {Top}" "~ (EX v::'a. A - {Top} = {Value v})"
    have "z <= Bot"
    proof (cases "A - {Top} = {Bot}")
      case True
      from this z show ?thesis
        by auto
    next
      case False
      from not_one_value
      obtain a1 where a1: "a1 : A - {Top}" by auto
      from not_one_value False a1
      obtain a2 where "a2 : A - {Top} \<and> a1 \<noteq> a2"
        by (cases a1) auto
      from this a1 z[of "a1"] z[of "a2"] show ?thesis
        apply (cases a1)
        apply auto
        apply (cases a2)
        apply auto
        apply (auto dest!: lesser_than_two_values)
        done
    qed
  } moreover
  note z moreover
  ultimately show "z <= Inf A"
    unfolding Inf_flat_complete_lattice_def
    by auto
next
  fix x A
  assume "(x :: 'a flat_complete_lattice) : A"
  {
    fix v
    assume "A - {Bot} = {Value v}"
    from this have "(THE v. A - {Bot} = {Value v}) = v"
      by (auto intro!: the1_equality)
    moreover
    from `x : A` `A - {Bot} = {Value v}` have "x = Bot \<or> x = Value v"
      by auto
    ultimately have "x <= Value (THE v. A - {Bot} = {Value v})"
      by auto
  }
  from `x : A` this show "x <= Sup A"
    unfolding Sup_flat_complete_lattice_def
    by fastforce
next
  fix z A
  assume z: "\<And>x. x : A ==> x <= (z :: 'a flat_complete_lattice)"
  {
    fix v
    assume "A - {Bot} = {Value v}"
    moreover
    from this have "(THE v. A - {Bot} = {Value v}) = v"
      by (auto intro!: the1_equality)
    moreover
    note z
    moreover
    ultimately have "Value (THE v::'a. A - {Bot} = {Value v}) <= z"
      by auto
  } moreover
  {
    assume not_one_value: "A ~= {}" "A ~= {Bot}" "~ (EX v::'a. A - {Bot} = {Value v})"
    have "Top <= z"
    proof (cases "A - {Bot} = {Top}")
      case True
      from this z show ?thesis
        by auto
    next
      case False
      from not_one_value
      obtain a1 where a1: "a1 : A - {Bot}" by auto
      from not_one_value False a1
      obtain a2 where "a2 : A - {Bot} \<and> a1 \<noteq> a2"
        by (cases a1) auto
      from this a1 z[of "a1"] z[of "a2"] show ?thesis
        apply (cases a1)
        apply auto
        apply (cases a2)
        apply (auto dest!: greater_than_two_values)
        done
    qed
  } moreover
  note z moreover
  ultimately show "Sup A <= z"
    unfolding Sup_flat_complete_lattice_def
    by auto
next
  show "Inf {} = (top :: 'a flat_complete_lattice)"
    by(simp add: Inf_flat_complete_lattice_def top_flat_complete_lattice_def)
next
  show "Sup {} = (bot :: 'a flat_complete_lattice)"
    by(simp add: Sup_flat_complete_lattice_def bot_flat_complete_lattice_def)
qed

end

end


subsection "Overall LuckyFind Proofs"
theory LuckyFind
  imports EliminateVariable
begin

theorem luckyFind_eval:
  assumes "luckyFind x L F = Some F'"
  assumes "length xs = x"
  shows "(\<exists>x. (eval (list_conj ((map Atom L) @ F)) (xs @ (x#\<Gamma>)))) = (\<exists>x.(eval F' (xs @ (x#\<Gamma>))))"
proof(cases "find_lucky_eq x L")
  case None
  then show ?thesis using assms by auto
next
  case (Some p)
  have inset : "Eq p \<in> set L"
    using Some proof(induction L)
    case Nil
    then show ?case by auto
  next
    case (Cons a L)
    then show ?case proof(cases a)
      case (Less x1)
      then show ?thesis using Cons by auto
    next
      case (Eq p')
      show ?thesis using Cons
        unfolding Eq apply simp apply(cases "(MPoly_Type.degree p' x = Suc 0 \<or> MPoly_Type.degree p' x = 2)") apply simp_all
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 2)") apply(simp_all)
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 1)") apply(simp_all)
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 0)") by(simp_all)
    next
      case (Leq x3)
      then show ?thesis using Cons by auto
    next
      case (Neq x4)
      then show ?thesis using Cons by auto
    qed
  qed
  have degree : "MPoly_Type.degree p x = 1 \<or> MPoly_Type.degree p x = 2"
    using Some proof(induction L)
    case Nil
    then show ?case by auto
  next
    case (Cons a L)
    then show ?case proof(cases a)
      case (Less x1)
      then show ?thesis using Cons by auto
    next
      case (Eq p')
      show ?thesis using Cons
        unfolding Eq apply simp apply(cases "(MPoly_Type.degree p' x = Suc 0 \<or> MPoly_Type.degree p' x = 2)") apply simp_all
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 2)") apply(simp_all)
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 1)") apply(simp_all)
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 0)") by(simp_all)
    next
      case (Leq x3)
      then show ?thesis using Cons by auto
    next
      case (Neq x4)
      then show ?thesis using Cons by auto
    qed
  qed
  have nonzero : "\<forall>xa. insertion (nth_default 0 (xs @ xa # \<Gamma>)) (isolate_variable_sparse p x 2) \<noteq> 0 \<or>
       insertion (nth_default 0 (xs @ xa # \<Gamma>)) (isolate_variable_sparse p x 1) \<noteq> 0 \<or>
       insertion (nth_default 0 (xs @ xa # \<Gamma>)) (isolate_variable_sparse p x 0) \<noteq> 0"
    using Some proof(induction L)
    case Nil
    then show ?case by auto
  next
    case (Cons a L)
    then show ?case proof(cases a)
      case (Less x1)
      then show ?thesis using Cons by auto
    next
      case (Eq p')
      have h : "\<And>p xa. check_nonzero_const p \<Longrightarrow> insertion (nth_default 0 (xs @ xa # \<Gamma>)) p \<noteq> 0"
      proof-
        fix p xa
        assume h : "check_nonzero_const p"
        show "insertion (nth_default 0 (xs @ xa # \<Gamma>)) p \<noteq> 0"
          apply(cases "get_if_const p")
          using h get_if_const_insertion by simp_all
      qed
      show ?thesis using Cons(2)
        unfolding Eq apply (simp del:get_if_const.simps) apply(cases "(MPoly_Type.degree p' x = Suc 0 \<or> MPoly_Type.degree p' x = 2)") defer using Cons apply simp
        apply (simp del:get_if_const.simps)
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 2)")
        apply(simp del:get_if_const.simps) using h
        apply simp
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 1)")
        apply(simp del:get_if_const.simps) using h
        apply simp
        apply(cases "check_nonzero_const (isolate_variable_sparse p' x 0)")
        apply(simp del:get_if_const.simps) using h
        apply simp
        using Cons by auto
    next
      case (Leq x3)
      then show ?thesis using Cons by auto
    next
      case (Neq x4)
      then show ?thesis using Cons by auto
    qed
  qed
  show ?thesis
    using elimVar_eq_2[OF assms(2) inset degree nonzero] Some assms by auto
qed

lemma luckyFind'_eval :
  assumes "length xs = var"
  shows "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) = (\<exists>x. eval (luckyFind' var L F) (xs @ x # \<Gamma>))"
proof(cases "find_lucky_eq var L")
  case None
  show ?thesis apply(simp add:eval_list_conj None)
    apply(rule ex_cong1)
    apply auto
    by (meson UnCI eval.simps(1) image_eqI)
next
  case (Some p)
  have "\<exists>F'. luckyFind var L F = Some F'" by (simp add:Some)
  then obtain F' where F'_def: "luckyFind var L F = Some F'" by metis
  show ?thesis
    unfolding luckyFind_eval[OF F'_def assms]
    using F'_def Some by auto
qed

lemma luckiestFind_eval :
  assumes "length xs = var"
  shows "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) = (\<exists>x. eval (luckiestFind var L F) (xs @ x # \<Gamma>))"
proof(cases "find_luckiest_eq var L")
  case None
  show ?thesis apply(simp add:eval_list_conj None)
    apply(rule ex_cong1)
    apply auto
    by (meson UnCI eval.simps(1) image_eqI)
next
  case (Some p)
  have h1: "Eq p \<in> set L"
    using Some apply(induction L arbitrary:p)
    apply simp
    subgoal for a L p
      apply(rule find_luckiest_eq.elims[of var "a#L" "Some p"])
      apply simp_all
      subgoal for v p'
        apply(cases "MPoly_Type.degree p' v = Suc 0 \<or> MPoly_Type.degree p' v = 2") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 2))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v (Suc 0)))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 0))") apply simp_all
        apply(cases "MPoly_Type.coeff (isolate_variable_sparse p' v (Suc 0)) 0 = 0 \<longrightarrow>
        MPoly_Type.coeff (isolate_variable_sparse p' v 2) 0 = 0 \<longrightarrow> MPoly_Type.coeff (isolate_variable_sparse p' v 0) 0 \<noteq> 0") by simp_all
      done
    done
  have h2 : "MPoly_Type.degree p var = 1 \<or> MPoly_Type.degree p var = 2"
    using Some apply(induction L arbitrary:p)
    apply simp
    subgoal for a L p
      apply(rule find_luckiest_eq.elims[of var "a#L" "Some p"])
      apply simp_all
      subgoal for v p'
        apply(cases "MPoly_Type.degree p' v = Suc 0 \<or> MPoly_Type.degree p' v = 2") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 2))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v (Suc 0)))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 0))") apply simp_all
        apply(cases "MPoly_Type.coeff (isolate_variable_sparse p' v (Suc 0)) 0 = 0 \<longrightarrow>
        MPoly_Type.coeff (isolate_variable_sparse p' v 2) 0 = 0 \<longrightarrow> MPoly_Type.coeff (isolate_variable_sparse p' v 0) 0 \<noteq> 0") by simp_all
      done
    done
  have h : "\<And>p xa. check_nonzero_const p \<Longrightarrow> insertion (nth_default 0 (xs @ xa # \<Gamma>)) p \<noteq> 0"
  proof-
    fix p xa
    assume h : "check_nonzero_const p"
    show "insertion (nth_default 0 (xs @ xa # \<Gamma>)) p \<noteq> 0"
      apply(cases "get_if_const p")
      using h get_if_const_insertion by simp_all
  qed

  have h3 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 2) \<noteq> 0 \<or>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 1) \<noteq> 0 \<or>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 0) \<noteq> 0"
    using Some apply(induction L arbitrary:p)
    apply simp
    subgoal for a L p
      apply(rule find_luckiest_eq.elims[of var "a#L" "Some p"])
      apply simp_all
      subgoal for v p'
        apply(cases "MPoly_Type.degree p' v = Suc 0 \<or> MPoly_Type.degree p' v = 2") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 2))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v (Suc 0)))") apply simp_all
        apply(cases "Set.is_empty (vars (isolate_variable_sparse p' v 0))") apply simp_all
        apply(cases "MPoly_Type.coeff (isolate_variable_sparse p' v (Suc 0)) 0 = 0 \<longrightarrow>
        MPoly_Type.coeff (isolate_variable_sparse p' v 2) 0 = 0 \<longrightarrow> MPoly_Type.coeff (isolate_variable_sparse p' v 0) 0 \<noteq> 0") apply simp_all
        using h[of "isolate_variable_sparse p' v 0"] h[of "isolate_variable_sparse p' v (Suc 0)"] h[of "isolate_variable_sparse p' v 2"] apply simp
        by blast
      done
    done
  show ?thesis  apply(simp_all add:Some del:elimVar.simps)
    apply(rule elimVar_eq_2) using assms apply simp using h1 h2 h3 by auto

qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Normalising Word Numerals"

theory Norm_Words
  imports Signed_Words
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval \<open>[0..2^len_of 'a)\<close>. Only for concrete word lengths.
\<close>

lemma bintrunc_numeral:
  "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
  by (simp add: numeral_eq_Suc take_bit_Suc mod_2_eq_odd)

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) = word_of_int (take_bit LENGTH('a) (- numeral x))"
  by transfer simp

ML \<open>
  fun is_refl \<^Const_>\<open>Pure.eq _ for x y\<close> = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT \<^Type>\<open>word \<^Type>\<open>signed T\<close>\<close> = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len \<^Const_>\<open>Num.Bit0 for n\<close> = num_len n + 1
    | num_len \<^Const_>\<open>Num.Bit1 for n\<close> = num_len n + 1
    | num_len \<^Const_>\<open>Num.One\<close> = 1
    | num_len \<^Const_>\<open>numeral _ for t\<close> = num_len t
    | num_len \<^Const_>\<open>uminus _ for t\<close> = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral} delsimps @{thms take_bit_minus_one_eq_mask})
        (* TODO: completely explicitly determined simpset *)
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ LENGTH('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

context
begin

private lemma "f (7 :: 2 word) = f 3" by simp

private

private lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

private lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

private lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

private lemma "(-1 :: 2 word) = 3" by simp

private lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

private lemma "f (-1) = f (15 :: 4 word)" by simp

private lemma "f (-1) = f (7 :: 3 word)" by simp

private lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

private lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end

end


(*  Title:      HOL/ex/Tree23.thy
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>2-3 Trees\<close>

theory Tree23
imports MainRLT
begin

hide_const (open) or

text\<open>This is a very direct translation of some of the functions in table.ML
in the Isabelle source code. That source is due to Makarius Wenzel and Stefan
Berghofer.

Note that because of complicated patterns and mutual recursion, these
function definitions take a few minutes and can also be seen as stress tests
for the function definition facility.\<close>

type_synonym key = int \<comment> \<open>for simplicity, should be a type class\<close>

datatype ord = LESS | EQUAL | GREATER

definition "ord i j = (if i<j then LESS else if i=j then EQUAL else GREATER)"

datatype 'a tree23 =
  Empty |
  Branch2 "'a tree23" "key * 'a" "'a tree23" |
  Branch3 "'a tree23" "key * 'a" "'a tree23" "key * 'a" "'a tree23"

datatype 'a growth =
  Stay "'a tree23" |
  Sprout "'a tree23" "key * 'a" "'a tree23"

fun add :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a growth" where
"add key y Empty = Sprout Empty (key,y) Empty" |
"add key y (Branch2 left (k,x) right) =
   (case ord key k of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch2 left' (k,x) right)
         | Sprout left1 q left2
           => Stay (Branch3 left1 q left2 (k,x) right))
    | EQUAL => Stay (Branch2 left (k,y) right)
    | GREATER =>
        (case add key y right of
           Stay right' => Stay (Branch2 left (k,x) right')
         | Sprout right1 q right2
           => Stay (Branch3 left (k,x) right1 q right2)))" |
"add key y (Branch3 left (k1,x1) mid (k2,x2) right) =
   (case ord key k1 of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch3 left' (k1,x1) mid (k2,x2) right)
         | Sprout left1 q left2
           => Sprout (Branch2 left1 q left2) (k1,x1) (Branch2 mid (k2,x2) right))
    | EQUAL => Stay (Branch3 left (k1,y) mid (k2,x2) right)
    | GREATER =>
        (case ord key k2 of
           LESS =>
             (case add key y mid of
                Stay mid' => Stay (Branch3 left (k1,x1) mid' (k2,x2) right)
              | Sprout mid1 q mid2
                => Sprout (Branch2 left (k1,x1) mid1) q (Branch2 mid2 (k2,x2) right))
         | EQUAL => Stay (Branch3 left (k1,x1) mid (k2,y) right)
         | GREATER =>
             (case add key y right of
                Stay right' => Stay (Branch3 left (k1,x1) mid (k2,x2) right')
              | Sprout right1 q right2
                => Sprout (Branch2 left (k1,x1) mid) (k2,x2) (Branch2 right1 q right2))))"

definition add0 :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"add0 k y t =
  (case add k y t of Stay t' => t' | Sprout l p r => Branch2 l p r)"

value "add0 5 e (add0 4 d (add0 3 c (add0 2 b (add0 1 a Empty))))"

fun compare where
"compare None (k2, _) = LESS" |
"compare (Some k1) (k2, _) = ord k1 k2"

fun if_eq where
"if_eq EQUAL x y = x" |
"if_eq _ x y = y"

fun del :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> ((key * 'a) * bool * 'a tree23)option"
where
"del (Some k) Empty = None" |
"del None (Branch2 Empty p Empty) = Some(p, (True, Empty))" |
"del None (Branch3 Empty p Empty q Empty) = Some(p, (False, Branch2 Empty q Empty))" |
"del k (Branch2 Empty p Empty) = (case compare k p of
      EQUAL => Some(p, (True, Empty)) | _ => None)" |
"del k (Branch3 Empty p Empty q Empty) = (case compare k p of
      EQUAL => Some(p, (False, Branch2 Empty q Empty))
    | _ => (case compare k q of
        EQUAL => Some(q, (False, Branch2 Empty p Empty))
      | _ => None))" |
"del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))" |
"del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"

definition del0 :: "key \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"del0 k t = (case del (Some k) t of None \<Rightarrow> t | Some(_,(_,t')) \<Rightarrow> t')"

text \<open>Ordered trees\<close>

definition opt_less :: "key option \<Rightarrow> key option \<Rightarrow> bool" where
  "opt_less x y = (case x of None \<Rightarrow> True | Some a \<Rightarrow> (case y of None \<Rightarrow> True | Some b \<Rightarrow> a < b))"

lemma opt_less_simps [simp]:
  "opt_less None y = True"
  "opt_less x None = True"
  "opt_less (Some a) (Some b) = (a < b)"
unfolding opt_less_def by (auto simp add: ord_def split: option.split)

primrec ord' :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> key option \<Rightarrow> bool" where
"ord' x Empty y = opt_less x y" |
"ord' x (Branch2 l p r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) r y)" |
"ord' x (Branch3 l p m q r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) m (Some (fst q)) & ord' (Some (fst q)) r y)"

definition ord0 :: "'a tree23 \<Rightarrow> bool" where
  "ord0 t = ord' None t None"

text \<open>Balanced trees\<close>

inductive full :: "nat \<Rightarrow> 'a tree23 \<Rightarrow> bool" where
"full 0 Empty" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch3 l p m q r)"

inductive_cases full_elims:
  "full n Empty"
  "full n (Branch2 l p r)"
  "full n (Branch3 l p m q r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Empty"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Empty_iff [simp]: "full n Empty \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch2_iff [simp]:
  "full (Suc n) (Branch2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch3_iff [simp]:
  "full (Suc n) (Branch3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

fun height :: "'a tree23 \<Rightarrow> nat" where
"height Empty = 0" |
"height (Branch2 l _ r) = Suc(max (height l) (height r))" |
"height (Branch3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

text\<open>Is a tree balanced?\<close>
fun bal :: "'a tree23 \<Rightarrow> bool" where
"bal Empty = True" |
"bal (Branch2 l _ r) = (bal l & bal r & height l = height r)" |
"bal (Branch3 l _ m _ r) = (bal l & bal m & bal r & height l = height m & height m = height r)"

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text \<open>The \<^term>\<open>add0\<close> function either preserves the height of the
tree, or increases it by one. The constructor returned by the \<^term>\<open>add\<close> function determines which: A return value of the form \<^term>\<open>Stay t\<close> indicates that the height will be the same. A value of the
form \<^term>\<open>Sprout l p r\<close> indicates an increase in height.\<close>

primrec gfull :: "nat \<Rightarrow> 'a growth \<Rightarrow> bool" where
"gfull n (Stay t) \<longleftrightarrow> full n t" |
"gfull n (Sprout l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma gfull_add: "full n t \<Longrightarrow> gfull n (add k y t)"
by (induct set: full, auto split: ord.split growth.split)

text \<open>The \<^term>\<open>add0\<close> operation preserves balance.\<close>

lemma bal_add0: "bal t \<Longrightarrow> bal (add0 k y t)"
unfolding bal_iff_full add0_def
apply (erule exE)
apply (drule gfull_add [of _ _ k y])
apply (cases "add k y t")
apply (auto intro: full.intros)
done

text \<open>The \<^term>\<open>add0\<close> operation preserves order.\<close>

lemma ord_cases:
  fixes a b :: int obtains
  "ord a b = LESS" and "a < b" |
  "ord a b = EQUAL" and "a = b" |
  "ord a b = GREATER" and "a > b"
unfolding ord_def by (rule linorder_cases [of a b]) auto

definition gtree :: "'a growth \<Rightarrow> 'a tree23" where
  "gtree g = (case g of Stay t \<Rightarrow> t | Sprout l p r \<Rightarrow> Branch2 l p r)"

lemma gtree_simps [simp]:
  "gtree (Stay t) = t"
  "gtree (Sprout l p r) = Branch2 l p r"
unfolding gtree_def by simp_all

lemma add0: "add0 k y t = gtree (add k y t)"
  unfolding add0_def by (simp split: growth.split)

lemma ord'_add0:
  "\<lbrakk>ord' k1 t k2; opt_less k1 (Some k); opt_less (Some k) k2\<rbrakk> \<Longrightarrow> ord' k1 (add0 k y t) k2"
unfolding add0
 apply (induct t arbitrary: k1 k2)
   apply simp
  apply clarsimp
  apply (rule_tac a=k and b=a in ord_cases)
    apply simp
    apply (case_tac "add k y t1", simp, simp)
   apply simp
  apply simp
  apply (case_tac "add k y t2", simp, simp)
 apply clarsimp
 apply (rule_tac a=k and b=a in ord_cases)
   apply simp
   apply (case_tac "add k y t1", simp, simp)
  apply simp
 apply simp
 apply (rule_tac a=k and b=aa in ord_cases)
   apply simp
   apply (case_tac "add k y t2", simp, simp)
  apply simp
 apply simp
 apply (case_tac "add k y t3", simp, simp)
done

lemma ord0_add0: "ord0 t \<Longrightarrow> ord0 (add0 k y t)"
  by (simp add: ord0_def ord'_add0)

text \<open>The \<^term>\<open>del\<close> function preserves balance.\<close>

lemma del_extra_simps:
"l \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))"
"l \<noteq> Empty \<or> m \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"
apply -
apply (cases l, cases r, simp_all only: del.simps, simp)
apply (cases l, cases m, cases r, simp_all only: del.simps, simp)
done

fun dfull where
"dfull n None \<longleftrightarrow> True" |
"dfull n (Some (p, (True, t'))) \<longleftrightarrow> full n t'" |
"dfull n (Some (p, (False, t'))) \<longleftrightarrow> full (Suc n) t'"

lemmas dfull_case_intros =
  ord.exhaust [of y "dfull a (case_ord b c d y)"]
  option.exhaust [of y "dfull a (case_option b c y)"]
  prod.exhaust [of y "dfull a (case_prod b y)"]
  bool.exhaust [of y "dfull a (case_bool b c y)"]
  tree23.exhaust [of y "dfull a (Some (b, case_tree23 c d e y))"]
  tree23.exhaust [of y "full a (case_tree23 b c d y)"]
  for a b c d e y

lemma dfull_del: "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
proof -
  { fix n :: "nat" and p :: "key \<times> 'a" and l r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k p = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k p = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch2 l p r)"
    hence "dfull n (del k (Branch2 l p r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     (* This should work, but it is way too slow!
     apply (force split: ord.split option.split bool.split tree23.split) *)
     apply (simp | rule dfull_case_intros)+
     done
  } note A = this
  { fix n :: "nat" and p q :: "key \<times> 'a" and l m r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k q = LESS; compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = EQUAL; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) m)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = GREATER; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) m)"
    and "\<And>n. \<lbrakk>compare k q = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k q = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch3 l p m q r)"
    hence "dfull n (del k (Branch3 l p m q r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     apply (simp | rule dfull_case_intros)+
     done
  } note B = this
  show "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
  proof (induct k t arbitrary: n rule: del.induct, goal_cases)
    case (1 k n)
    thus "dfull n (del (Some k) Empty)" by simp
  next
    case (2 p n)
    thus "dfull n (del None (Branch2 Empty p Empty))" by simp
  next
    case (3 p q n)
    thus "dfull n (del None (Branch3 Empty p Empty q Empty))" by simp
  next
    case (4 v p n)
    thus "dfull n (del (Some v) (Branch2 Empty p Empty))"
      by (simp split: ord.split)
  next
    case (5 v p q n)
    thus "dfull n (del (Some v) (Branch3 Empty p Empty q Empty))"
      by (simp split: ord.split)
  next
    case (26 n)
    thus ?case by simp
  qed (fact A | fact B)+
qed

lemma bal_del0: "bal t \<Longrightarrow> bal (del0 k t)"
unfolding bal_iff_full del0_def
apply (erule exE)
apply (case_tac n, simp, simp)
apply (frule dfull_del [where k="Some k"])
apply (cases "del (Some k) t", force)
apply (rename_tac a, case_tac "a", rename_tac b t', case_tac "b", auto)
done

text\<open>This is a little test harness and should be commented out once the
above functions have been proved correct.\<close>

datatype 'a act = Add int 'a | Del int

fun exec where
"exec [] t = t" |
"exec (Add k x # as) t = exec as (add0 k x t)" |
"exec (Del k # as) t = exec as (del0 k t)"

text\<open>Some quick checks:\<close>

lemma bal_exec: "bal t \<Longrightarrow> bal (exec as t)"
  by (induct as t arbitrary: t rule: exec.induct,
    simp_all add: bal_add0 bal_del0)

lemma "bal(exec as Empty)"
  by (simp add: bal_exec)

lemma "ord0(exec as Empty)"
quickcheck
oops

end


(*  Title:      ZF/QUniv.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section\<open>A Small Universe for Lazy Recursive Types\<close>

theory QUniv imports Univ QPair begin

(*Disjoint sums as a datatype*)
rep_datatype
  elimination   sumE
  induction     TrueI
  case_eqns     case_Inl case_Inr

(*Variant disjoint sums as a datatype*)
rep_datatype
  elimination   qsumE
  induction     TrueI
  case_eqns     qcase_QInl qcase_QInr

definition
  quniv :: "i => i"  where
   "quniv(A) == Pow(univ(eclose(A)))"

subsection\<open>Properties involving Transset and Sum\<close>

lemma Transset_includes_summands:
     "[| Transset(C); A+B \<subseteq> C |] ==> A \<subseteq> C & B \<subseteq> C"
apply (simp add: sum_def Un_subset_iff)
apply (blast dest: Transset_includes_range)
done

lemma Transset_sum_Int_subset:
     "Transset(C) ==> (A+B) \<inter> C \<subseteq> (A \<inter> C) + (B \<inter> C)"
apply (simp add: sum_def Int_Un_distrib2)
apply (blast dest: Transset_Pair_D)
done

subsection\<open>Introduction and Elimination Rules\<close>

lemma qunivI: "X \<subseteq> univ(eclose(A)) ==> X \<in> quniv(A)"
by (simp add: quniv_def)

lemma qunivD: "X \<in> quniv(A) ==> X \<subseteq> univ(eclose(A))"
by (simp add: quniv_def)

lemma quniv_mono: "A<=B ==> quniv(A) \<subseteq> quniv(B)"
apply (unfold quniv_def)
apply (erule eclose_mono [THEN univ_mono, THEN Pow_mono])
done

subsection\<open>Closure Properties\<close>

lemma univ_eclose_subset_quniv: "univ(eclose(A)) \<subseteq> quniv(A)"
apply (simp add: quniv_def Transset_iff_Pow [symmetric])
apply (rule Transset_eclose [THEN Transset_univ])
done

(*Key property for proving A_subset_quniv; requires eclose in definition of quniv*)
lemma univ_subset_quniv: "univ(A) \<subseteq> quniv(A)"
apply (rule arg_subset_eclose [THEN univ_mono, THEN subset_trans])
apply (rule univ_eclose_subset_quniv)
done

lemmas univ_into_quniv = univ_subset_quniv [THEN subsetD]

lemma Pow_univ_subset_quniv: "Pow(univ(A)) \<subseteq> quniv(A)"
apply (unfold quniv_def)
apply (rule arg_subset_eclose [THEN univ_mono, THEN Pow_mono])
done

lemmas univ_subset_into_quniv =
    PowI [THEN Pow_univ_subset_quniv [THEN subsetD]]

lemmas zero_in_quniv = zero_in_univ [THEN univ_into_quniv]
lemmas one_in_quniv = one_in_univ [THEN univ_into_quniv]
lemmas two_in_quniv = two_in_univ [THEN univ_into_quniv]

lemmas A_subset_quniv =  subset_trans [OF A_subset_univ univ_subset_quniv]

lemmas A_into_quniv = A_subset_quniv [THEN subsetD]

(*** univ(A) closure for Quine-inspired pairs and injections ***)

(*Quine ordered pairs*)
lemma QPair_subset_univ:
    "[| a \<subseteq> univ(A);  b \<subseteq> univ(A) |] ==> <a;b> \<subseteq> univ(A)"
by (simp add: QPair_def sum_subset_univ)

subsection\<open>Quine Disjoint Sum\<close>

lemma QInl_subset_univ: "a \<subseteq> univ(A) ==> QInl(a) \<subseteq> univ(A)"
apply (unfold QInl_def)
apply (erule empty_subsetI [THEN QPair_subset_univ])
done

lemmas naturals_subset_nat =
    Ord_nat [THEN Ord_is_Transset, unfolded Transset_def, THEN bspec]

lemmas naturals_subset_univ =
    subset_trans [OF naturals_subset_nat nat_subset_univ]

lemma QInr_subset_univ: "a \<subseteq> univ(A) ==> QInr(a) \<subseteq> univ(A)"
apply (unfold QInr_def)
apply (erule nat_1I [THEN naturals_subset_univ, THEN QPair_subset_univ])
done

subsection\<open>Closure for Quine-Inspired Products and Sums\<close>

(*Quine ordered pairs*)
lemma QPair_in_quniv:
    "[| a: quniv(A);  b: quniv(A) |] ==> <a;b> \<in> quniv(A)"
by (simp add: quniv_def QPair_def sum_subset_univ)

lemma QSigma_quniv: "quniv(A) <*> quniv(A) \<subseteq> quniv(A)"
by (blast intro: QPair_in_quniv)

lemmas QSigma_subset_quniv =  subset_trans [OF QSigma_mono QSigma_quniv]

(*The opposite inclusion*)
lemma quniv_QPair_D:
    "<a;b> \<in> quniv(A) ==> a: quniv(A) & b: quniv(A)"
apply (unfold quniv_def QPair_def)
apply (rule Transset_includes_summands [THEN conjE])
apply (rule Transset_eclose [THEN Transset_univ])
apply (erule PowD, blast)
done

lemmas quniv_QPair_E = quniv_QPair_D [THEN conjE]

lemma quniv_QPair_iff: "<a;b> \<in> quniv(A) \<longleftrightarrow> a: quniv(A) & b: quniv(A)"
by (blast intro: QPair_in_quniv dest: quniv_QPair_D)

subsection\<open>Quine Disjoint Sum\<close>

lemma QInl_in_quniv: "a: quniv(A) ==> QInl(a) \<in> quniv(A)"
by (simp add: QInl_def zero_in_quniv QPair_in_quniv)

lemma QInr_in_quniv: "b: quniv(A) ==> QInr(b) \<in> quniv(A)"
by (simp add: QInr_def one_in_quniv QPair_in_quniv)

lemma qsum_quniv: "quniv(C) <+> quniv(C) \<subseteq> quniv(C)"
by (blast intro: QInl_in_quniv QInr_in_quniv)

lemmas qsum_subset_quniv = subset_trans [OF qsum_mono qsum_quniv]

subsection\<open>The Natural Numbers\<close>

lemmas nat_subset_quniv =  subset_trans [OF nat_subset_univ univ_subset_quniv]

(* n:nat ==> n:quniv(A) *)
lemmas nat_into_quniv = nat_subset_quniv [THEN subsetD]

lemmas bool_subset_quniv = subset_trans [OF bool_subset_univ univ_subset_quniv]

lemmas bool_into_quniv = bool_subset_quniv [THEN subsetD]

(*Intersecting <a;b> with Vfrom...*)

lemma QPair_Int_Vfrom_succ_subset:
 "Transset(X) ==>
       <a;b> \<inter> Vfrom(X, succ(i))  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
by (simp add: QPair_def sum_def Int_Un_distrib2 Un_mono
              product_Int_Vfrom_subset [THEN subset_trans]
              Sigma_mono [OF Int_lower1 subset_refl])

subsection\<open>"Take-Lemma" Rules\<close>

(*for proving a=b by coinduction and c: quniv(A)*)

(*Rule for level i -- preserving the level, not decreasing it*)

lemma QPair_Int_Vfrom_subset:
 "Transset(X) ==>
       <a;b> \<inter> Vfrom(X,i)  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
apply (unfold QPair_def)
apply (erule Transset_Vfrom [THEN Transset_sum_Int_subset])
done

(*@{term"[| a \<inter> Vset(i) \<subseteq> c; b \<inter> Vset(i) \<subseteq> d |] ==> <a;b> \<inter> Vset(i) \<subseteq> <c;d>"}*)
lemmas QPair_Int_Vset_subset_trans =
     subset_trans [OF Transset_0 [THEN QPair_Int_Vfrom_subset] QPair_mono]

lemma QPair_Int_Vset_subset_UN:
     "Ord(i) ==> <a;b> \<inter> Vset(i) \<subseteq> (\<Union>j\<in>i. <a \<inter> Vset(j); b \<inter> Vset(j)>)"
apply (erule Ord_cases)
(*0 case*)
apply (simp add: Vfrom_0)
(*succ(j) case*)
apply (erule ssubst)
apply (rule Transset_0 [THEN QPair_Int_Vfrom_succ_subset, THEN subset_trans])
apply (rule succI1 [THEN UN_upper])
(*Limit(i) case*)
apply (simp del: UN_simps
        add: Limit_Vfrom_eq Int_UN_distrib UN_mono QPair_Int_Vset_subset_trans)
done

end