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

subsection \<open>Auxiliary bounds\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end

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

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

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

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

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

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

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

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

end

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

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

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

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

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

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

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

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

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

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

end


theory HardL
imports MediumL
        "../Nat-prfs/ProofN"

begin

fun sorted :: "Nat List \<Rightarrow> bool" where
  "sorted Nil                   = True"
| "sorted (Cons _ Nil)          = True"
| "sorted (Cons r (Cons t ts))  = (leq r t \<and> sorted (Cons t ts))"

fun insert :: "Nat \<Rightarrow> Nat List \<Rightarrow> Nat List" where
  "insert r Nil         = Cons r Nil"
| "insert r (Cons t ts) = (if leq r t then Cons r (Cons t ts) else (Cons t (insert r ts)))"

fun isort :: "Nat List \<Rightarrow> Nat List" where
  "isort Nil = Nil"
| "isort (Cons t ts) = insert t (isort ts)"

fun qsort :: "Nat list \<Rightarrow> Nat list" where
  "qsort [] = []"
| "qsort (t # ts) = [r . r <- ts, leq r t] @ (t # [r . r <- ts, \<not> (leq r t)])"

fun sorted' :: "Nat list \<Rightarrow> bool" where
  "sorted' []                   = True"
| "sorted' [x]         = True"
| "sorted' (r # (t # ts))  = (leq r t \<and>  sorted' (t # ts))"

fun count' :: "'a \<Rightarrow> 'a List \<Rightarrow> Nat" where
  "count' n Nil = Z"
| "count' n (Cons t ts) = (if n = t then S (count' n ts) else count' n ts)"

fun elem' :: "'a \<Rightarrow> 'a List \<Rightarrow> bool" where
  "elem' n Nil = False"
| "elem' n (Cons t ts) = (n = t \<or> elem' n ts)"

lemma elemIns0: "elem t (insert t ts)"
by hipster_induct_simp_metis

lemma elemIns : "\<not> eqN r t \<Longrightarrow> elem r (insert t ts) = elem r ts"
by hipster_induct_simp_metis

lemma elemCount: "elem t ts \<Longrightarrow> lt Z (count t ts)"
by hipster_induct_simp_metis

lemma countIns: "S (count t ts) = count t (insert t ts)"
by hipster_induct_simp_metis

lemma eqEq: "eqN r t = (r = t)"
by hipster_induct_schemes

lemma countIns0: "\<not> eqN r t \<Longrightarrow> count t ts = count t (insert r ts)"
by hipster_induct_schemes

lemma setCountSort: "count t ts = count t (isort ts)"
by (hipster_induct_schemes eqEq countIns0 countIns)  (* XXX: something weird with regular induct: shouldn't *)

lemma subLCount : "leq (count t ts) (len ts)"
by (hipster_induct_simp_metis succIncreasesL)
(* apply(induction t ts rule: count.induct)
apply(simp_all add: succIncreasesL)*)

(*lemma count2 : "leq (add (count t ts) (count r ts)) (len ts)"
apply (hipster_induct_schemes count03 subLCount)*)

lemma symList  : "ts = rev ts \<Longrightarrow> app (rev (drop n ts)) (rev (take n ts)) = ts"
(*apply (hipster_induct_schemes dropTake)*)
oops

lemma insLen : "len (insert t ts) = S (len ts)"
by hipster_induct_simp_metis (*
apply(induction ts)
apply(simp_all)
oops*)

lemma lenIsort : "len (isort ts) = len ts"
by (hipster_induct_simp_metis insLen)

(* XXX: DO NOT RUN with hipster_induct_schemes *)
lemma appZips  : "len a = len b \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"
(*apply(hipster_induct_schemes app.simps len.simps List.exhaust Nat.distinct)*)
(*apply hipster_induct_schemes*)
apply (hipster_induct_schemes app.simps len.simps List.exhaust Nat.exhaust)
done
(*by (tactic {* let
      val lemmas = [] (* (ThyExpl_Data.proved_of_ctxt @{context}) @ (Hipster_Rules.get @{context})*)
      val facts = @{thms app.simps  len.simps List.exhaust Nat.distinct} in
        ALLGOALS(Ind_Tacs.induct_simp_or_metis (facts,lemmas) @{context} (SOME @{thms "zip.induct"}) (SOME ["a","b"]))
      end*})*)
(*apply(induction a b rule: zip.induct)
apply(simp_all)
by (metis app.simps len.simps List.exhaust Nat.distinct)*)

lemma auxRev : "rev (rev (Cons a Nil)) = Cons a Nil"
by (tactic \<open>Tactic_Data.routine_tac @{context}\<close>)

lemma revA : "rev (app xs (Cons x Nil)) = app (rev (Cons x Nil)) (rev xs)"
by hipster_induct_simp_metis

declare [[ML_print_depth = 100]]

lemma revA' : "rev (app xs (Cons x Nil)) = Cons x (rev xs)"
by hipster_induct_simp_metis

(* FIXME: there is something wrong going on with the simplifying part: the following is resolved
    without any issues, however it won't do so with
      by (hipster_induct_schemes revA) nor by (hipster_induct_simp_metis revA) *)
lemma revRev  : "rev (rev xs) = xs"
by (hipster_induct_simp_metis revA') (*revA'*)
(*apply(induction xs rule: rev.induct)
apply(simp_all)
apply(metis rev.simps revA')
*)

(*hipster rev app*)
lemma lemma_ab : "app (app x y) x = app x (app y x)"
by hipster_induct_simp_metis

lemma lemma_ad : "app (app x y) y = app x (app y y)"
by hipster_induct_simp_metis

lemma lemma_ae : "app (app x x) y = app x (app x y)"
by hipster_induct_simp_metis

lemma appAssoc : "app (app x y) z = app x (app y z)"
by hipster_induct_simp_metis

lemma appNil: "app ts Nil = ts" (* borrowed from BasicL *)
by hipster_induct_simp_metis

lemma appRevAntiDistr [thy_expl] : "app (rev x) (rev y) = rev (app y x)"
by (hipster_induct_simp_metis appNil appAssoc)

lemma revApp: "rev (app xs ts) = app (rev ts) (rev xs)"
by (hipster_induct_simp_metis appAssoc app.simps)

(* immediately follows *)
lemma s : "t = rev t \<Longrightarrow> rev (app t t) = app t t"
(*apply(hipster_induct_schemes revA appNil appAssoc)*)
by (tactic \<open>Tactic_Data.routine_tac @{context}\<close>)

lemma revCons: "rev (Cons t ts) = app (rev ts) (Cons t Nil)"
by simp

(* XXX: DO NOT RUN with hipster_induct_schemes *)
lemma revZip: "len rs = len ts \<Longrightarrow> rev (zip rs ts) = zip (rev rs) (rev ts)"
apply(induction rs ts rule: zip.induct)
apply(simp_all (*add: appZips*))
oops

end


section \<open> Relational Universe \<close>

theory Relation_Extra
  imports "HOL-Library.FuncSet" "HOL-Library.AList" List_Extra Overriding
begin

text \<open> This theory develops a universe for a Z-like relational language, including the core
  operators of the ISO Z metalanguage. Much of this already exists in @{theory HOL.Relation},
  but we need to add some additional functions and sets. It characterises relations, partial
  functions, total functions, and finite functions. \<close>

subsection \<open> Type Syntax\<close>

text \<open> We set up some nice syntax for heterogeneous relations at the type level \<close>

syntax
  "_rel_type" :: "type \<Rightarrow> type \<Rightarrow> type" (infixr "\<leftrightarrow>" 0)

translations
  (type) "'a \<leftrightarrow> 'b" == (type) "('a \<times> 'b) set"

text \<open> Setup pretty printing for homogeneous relations. \<close>

print_translation \<open>
let fun tr' ctx [ Const (@{type_syntax "prod"},_) $ a $ b ] =
      if a = b then Syntax.const @{type_syntax "rel"} $ a else raise Match;
in [(@{type_syntax "set"},tr')]
end
\<close>

subsection \<open> Notation for types as sets \<close>

definition "TUNIV (a::'a itself) = (UNIV :: 'a set)"

syntax "_tvar" :: "type \<Rightarrow> logic" ("[_]\<^sub>T")
translations "['a]\<^sub>T" == "CONST TUNIV TYPE('a)"

lemma TUNIV_mem [simp]: "x \<in> ['a]\<^sub>T"
  by (simp add: TUNIV_def)

subsection \<open> Relational Function Operations \<close>

text \<open> These functions are all adapted from their ISO Z counterparts. \<close>

definition rel_apply :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>r" [999,0] 999) where
"rel_apply R x = (if (\<exists>! y. (x, y) \<in> R) then THE y. (x, y) \<in> R else undefined)"

text \<open> If there exists a unique @{term "e\<^sub>3"} such that @{term "(e\<^sub>2, e\<^sub>3)"} is in @{term "e\<^sub>1"}, then
  the value of @{term "e\<^sub>1(e\<^sub>2)\<^sub>r"} is @{term e\<^sub>3}, otherwise each @{term "e\<^sub>1(e\<^sub>2)\<^sub>r"} has a fixed but
  unknown value (i.e. @{const undefined}). \<close>

definition rel_domres :: "'a set \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<leftrightarrow> 'b" (infixr "\<lhd>\<^sub>r" 85) where
"rel_domres A R = {p \<in> R. fst p \<in> A}"

lemma rel_domres_math_def: "A \<lhd>\<^sub>r R = {(k, v) \<in> R. k \<in> A}"
  by (auto simp add: rel_domres_def)

text \<open> Domain restriction (@{term "A \<lhd>\<^sub>r R"} contains the set of pairs in @{term R}, such that the
  first element of every such pair in in @{term A}. \<close>

definition rel_ranres :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a \<leftrightarrow> 'b" (infixl "\<rhd>\<^sub>r" 85) where
"rel_ranres R A = {p \<in> R. snd p \<in> A}"

text \<open> We employ some type class trickery to enable a polymorphic operator for override that can
  instantiate @{typ "'a set"}, which is needed for relational overriding. The following class's
  sole purpose is to allow pairs to be the only valid instantiation element for the set type. \<close>

class pre_restrict =
  fixes cmpt :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  and res :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"

instantiation prod :: (type, type) pre_restrict
begin

text \<open> Relations are compatible is they agree on the values for maplets they both possess. \<close>

definition cmpt_prod :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> bool"
  where [simp]: "cmpt_prod R S = ((Domain R) \<lhd>\<^sub>r S = (Domain S) \<lhd>\<^sub>r R)"
definition res_prod :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<leftrightarrow> 'b"
  where [simp]: "res_prod R S = ((- Domain S) \<lhd>\<^sub>r R) \<union> S"
instance ..
end

instantiation set :: (pre_restrict) oplus
begin

definition oplus_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"oplus_set = res"

instance ..

end

definition rel_update :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<leftrightarrow> 'b" where
"rel_update R k v = R \<oplus> {(k, v)}"

text \<open> Relational update adds a new pair to a relation. \<close>

definition rel_disjoint :: "('a \<leftrightarrow> 'b set) \<Rightarrow> bool" where
"rel_disjoint f = (\<forall> p \<in> f. \<forall> q \<in> f. p \<noteq> q \<longrightarrow> snd p \<inter> snd q = {})"

definition rel_partitions :: "('a \<leftrightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> bool" where
"rel_partitions f a = (rel_disjoint f \<and> \<Union> (Range f) = a)"

subsection \<open> Domain laws \<close>

declare Domain_Un_eq [simp]

lemma Domain_Preimage: "Domain P = P\<inverse> `` UNIV"
  by (simp add: Image_def Domain_unfold)

lemma Domain_relcomp [simp]: "Domain (P O Q) = Domain (P \<rhd>\<^sub>r Domain Q)"
  by (force simp add: Domain_iff rel_ranres_def)

lemma Domain_relcomp_conv: "Domain (P O Q) = (P\<inverse> `` Domain(Q))"
  by (simp add: Domain_Preimage converse_relcomp relcomp_Image)

lemma Domain_set: "Domain (set xs) = set (map fst xs)"
  by (simp add: Domain_fst)

subsection \<open> Range laws \<close>

lemma Range_Image: "Range P = P `` UNIV"
  by (simp add: Image_def Range_iff set_eq_iff)

lemma Range_relcomp: "Range (P O Q) = (Q `` Range(P))"
  by (simp add: Range_Image relcomp_Image)

subsection \<open> Domain Restriction \<close>

lemma Domain_rel_domres [simp]: "Domain (A \<lhd>\<^sub>r R) = A \<inter> Domain(R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_empty [simp]: "{} \<lhd>\<^sub>r R = {}"
  by (simp add: rel_domres_def)

lemma rel_domres_UNIV [simp]: "UNIV \<lhd>\<^sub>r R = R"
  by (simp add: rel_domres_def)

lemma rel_domres_nil [simp]: "A \<lhd>\<^sub>r {} = {}"
  by (simp add: rel_domres_def)

lemma rel_domres_inter [simp]: "A \<lhd>\<^sub>r B \<lhd>\<^sub>r R = (A \<inter> B) \<lhd>\<^sub>r R"
  by (auto simp add: rel_domres_def)

lemma rel_domres_compl_disj: "A \<inter> Domain P = {} \<Longrightarrow> (- A) \<lhd>\<^sub>r P = P"
  by (auto simp add: rel_domres_def)

lemma rel_domres_notin_Dom: "k \<notin> Domain(f) \<Longrightarrow> (- {k}) \<lhd>\<^sub>r f = f"
  by (simp add: rel_domres_compl_disj)

lemma rel_domres_Id_on: "A \<lhd>\<^sub>r R = Id_on A O R"
  by (auto simp add: rel_domres_def Id_on_def relcomp_unfold)

lemma rel_domres_insert [simp]:
 "A \<lhd>\<^sub>r insert (k, v) R = (if (k \<in> A) then insert (k, v) (A \<lhd>\<^sub>r R) else A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_insert_set [simp]: "x \<notin> Domain P \<Longrightarrow> (insert x A) \<lhd>\<^sub>r P = A \<lhd>\<^sub>r P"
  by (auto simp add: rel_domres_def)

lemma Image_as_rel_domres: "R `` A = Range (A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_Un [simp]: "A \<lhd>\<^sub>r (S \<union> R) = (A \<lhd>\<^sub>r S) \<union> (A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

subsection \<open> Range Restriction \<close>

lemma rel_ranres_UNIV [simp]: "P \<rhd>\<^sub>r UNIV = P"
  by (auto simp add: rel_ranres_def)

lemma rel_ranres_Un [simp]: "(P \<union> Q) \<rhd>\<^sub>r A = (P \<rhd>\<^sub>r A \<union> Q \<rhd>\<^sub>r A)"
  by (auto simp add: rel_ranres_def)

lemma rel_ranres_relcomp [simp]: "(P O Q) \<rhd>\<^sub>r A = P O (Q \<rhd>\<^sub>r A)"
  by (auto simp add: rel_ranres_def relcomp_unfold prod.case_eq_if)

lemma conv_rel_domres [simp]: "(P \<rhd>\<^sub>r A)\<inverse> = A \<lhd>\<^sub>r P\<inverse>"
  by (auto simp add: rel_domres_def rel_ranres_def)

lemma rel_ranres_le: "A \<subseteq> B \<Longrightarrow> f \<rhd>\<^sub>r A \<le> f \<rhd>\<^sub>r B"
  by (simp add: Collect_mono_iff in_mono rel_ranres_def)

subsection \<open> Relational Override \<close>

class restrict = pre_restrict +
  assumes cmpt_sym: "cmpt P Q \<Longrightarrow> cmpt Q P"
  and cmpt_empty: "cmpt {} P"
  assumes res_idem: "res P P = P"
  and res_assoc: "res P (res Q R) = res (res P Q) R"
  and res_lzero: "res {} P = P"
  and res_comm: "cmpt P Q \<Longrightarrow> res P Q = res Q P"
  and res_cmpt: "\<lbrakk> cmpt P Q; cmpt (res P Q) R \<rbrakk> \<Longrightarrow> cmpt P R"
  and res_cmptI: "\<lbrakk> cmpt P Q; cmpt P R; cmpt Q R \<rbrakk> \<Longrightarrow> cmpt (res P Q) R"

lemma res_cmpt_rel: "cmpt (P :: 'a \<leftrightarrow> 'b) Q \<Longrightarrow> cmpt (res P Q) R \<Longrightarrow> cmpt P R"
  by (fastforce simp add: rel_domres_def Domain_iff)

instance prod :: (type, type) restrict
  by (intro_classes, simp_all only: res_cmpt_rel, auto simp add: rel_domres_def Domain_unfold)

instantiation set :: (restrict) override
begin
definition compatible_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"compatible_set = cmpt"

instance
  apply (intro_classes, simp_all add: oplus_set_def compatible_set_def res_idem res_assoc res_lzero cmpt_sym cmpt_empty res_comm res_cmptI)
  using res_cmpt apply blast
  done
end

lemma override_eq: "R \<oplus> S = ((- Domain S) \<lhd>\<^sub>r R) \<union> S"
  by (simp add: oplus_set_def)

lemma Domain_rel_override [simp]: "Domain (R \<oplus> S) = Domain(R) \<union> Domain(S)"
  by (auto simp add: oplus_set_def Domain_Un_eq)

lemma Range_rel_override: "Range(R \<oplus> S) \<subseteq> Range(R) \<union> Range(S)"
  by (auto simp add: oplus_set_def rel_domres_def)

lemma compatible_rel: "R ## S = (Domain R \<lhd>\<^sub>r S = Domain S \<lhd>\<^sub>r R)"
  by (simp add: compatible_set_def)

lemma compatible_relI: "Domain R \<lhd>\<^sub>r S = Domain S \<lhd>\<^sub>r R \<Longrightarrow> R ## S"
  by (simp add: compatible_rel)

subsection \<open> Functional Relations \<close>

abbreviation functional :: "('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"functional R \<equiv> single_valued R"

lemma functional_def: "functional R \<longleftrightarrow> inj_on fst R"
  by (force simp add: single_valued_def inj_on_def)

lemma functional_algebraic: "functional R \<longleftrightarrow> R\<inverse> O R \<subseteq> Id"
  apply (auto simp add: functional_def subset_iff relcomp_unfold)
  using inj_on_eq_iff apply fastforce
  apply (metis inj_onI surjective_pairing)
  done

lemma functional_apply:
  assumes "functional R" "(x, y) \<in> R"
  shows "R(x)\<^sub>r = y"
  by (metis (no_types, lifting) Domain.intros DomainE assms(1) assms(2) single_valuedD rel_apply_def theI_unique)

lemma functional_apply_iff: "functional R \<Longrightarrow> (x, y) \<in> R \<longleftrightarrow> (x \<in> Domain R \<and> R(x)\<^sub>r = y)"
  by (auto simp add: functional_apply)

lemma functional_elem:
  assumes "functional R" "x \<in> Domain(R)"
  shows "(x, R(x)\<^sub>r) \<in> R"
  using assms(1) assms(2) functional_apply by fastforce

lemma functional_override [intro!]: "\<lbrakk> functional R; functional S \<rbrakk> \<Longrightarrow> functional (R \<oplus> S)"
  by (auto simp add: functional_algebraic oplus_set_def rel_domres_def)

lemma functional_union [intro!]: "\<lbrakk> functional R; functional S; R ## S \<rbrakk> \<Longrightarrow> functional (R \<union> S)"
  by (metis functional_override le_sup_iff override_comm override_eq single_valued_subset subsetI)

definition functional_list :: "('a \<times> 'b) list \<Rightarrow> bool" where
"functional_list xs = (\<forall> x y z. ListMem (x,y) xs \<and> ListMem (x,z) xs \<longrightarrow> y = z)"

lemma functional_insert [simp]: "functional (insert (x,y) g) \<longleftrightarrow> (g``{x} \<subseteq> {y} \<and> functional g)"
  by (auto simp add:functional_def inj_on_def image_def)

lemma functional_list_nil[simp]: "functional_list []"
  by (simp add:functional_list_def ListMem_iff)

lemma functional_list: "functional_list xs \<longleftrightarrow> functional (set xs)"
  apply (induct xs)
   apply (simp add:functional_def)
  apply (simp add:functional_def functional_list_def ListMem_iff)
  apply (safe)
         apply (force)
        apply (force)
       apply (force)
      apply (force)
     apply (force)
    apply (force)
   apply (force)
  apply (force)
  done

definition fun_rel :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b)" where
"fun_rel f = {(x, y). y = f x}"

lemma functional_fun_rel: "functional (fun_rel f)"
  by (simp add: fun_rel_def functional_def)
     (metis (mono_tags, lifting) Product_Type.Collect_case_prodD inj_onI prod.expand)

lemma rel_apply_fun [simp]: "(fun_rel f)(x)\<^sub>r = f x"
  by (simp add: fun_rel_def rel_apply_def)

text \<open> Make a relation functional by removing any pairs that have duplicate distinct values. \<close>

definition mk_functional :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b)" where
"mk_functional R = {(x, y) \<in> R. \<forall> y'. (x, y') \<in> R \<longrightarrow> y = y'}"

lemma mk_functional [simp]: "functional (mk_functional R)"
  by (auto simp add: mk_functional_def single_valued_def)

lemma mk_functional_fp: "functional R \<Longrightarrow> mk_functional R = R"
  by (auto simp add: mk_functional_def single_valued_def)

lemma mk_functional_idem: "mk_functional (mk_functional R) = mk_functional R"
  using mk_functional mk_functional_fp by blast

lemma mk_functional_subset [simp]: "mk_functional R \<subseteq> R"
  by (auto simp add: mk_functional_def)

lemma Domain_mk_functional: "Domain (mk_functional R) \<subseteq> Domain R"
  by (auto simp add: mk_functional_def)

definition single_valued_dom :: "('a \<times> 'b) set \<Rightarrow> 'a set" where
"single_valued_dom R = {x \<in> Domain(R). \<exists> y. R `` {x} = {y}}"

lemma mk_functional_single_valued_dom: "mk_functional R = single_valued_dom R \<lhd>\<^sub>r R"
  by (auto simp add: mk_functional_def single_valued_dom_def rel_domres_math_def Domain_unfold)
     (metis Image_singleton_iff singletonD)

subsection \<open> Left-Total Relations\<close>

definition left_totalr_on :: "'a set \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"left_totalr_on A R \<longleftrightarrow> (\<forall>x\<in>A. \<exists>y. (x, y) \<in> R)"

abbreviation "left_totalr R \<equiv> left_totalr_on UNIV R"

lemma left_totalr_algebraic: "left_totalr R \<longleftrightarrow> Id \<subseteq> R O R\<inverse>"
  by (auto simp add: left_totalr_on_def)

lemma left_totalr_fun_rel: "left_totalr (fun_rel f)"
  by (simp add: left_totalr_on_def fun_rel_def)

subsection \<open> Injective Relations \<close>

definition injective :: "('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"injective R = (functional R \<and> R O R\<inverse> \<subseteq> Id)"

lemma injectiveI:
  assumes "functional R" "\<And> x y. \<lbrakk> x \<in> Domain R; y \<in> Domain R; R(x)\<^sub>r = R(y)\<^sub>r \<rbrakk> \<Longrightarrow> x = y"
  shows "injective R"
  using assms by (auto simp add: injective_def functional_apply_iff)

subsection \<open> Relation Sets \<close>

definition rel_typed :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<leftrightarrow>" 55) where
"rel_typed A B = {R. Domain(R) \<subseteq> A \<and> Range(R) \<subseteq> B}" \<comment> \<open> Relations \<close>

lemma rel_typed_intro: "\<lbrakk> Domain(R) \<subseteq> A; Range(R) \<subseteq> B \<rbrakk> \<Longrightarrow> R \<in> A \<leftrightarrow> B"
  by (simp add: rel_typed_def)

definition rel_pfun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>p" 55) where
"rel_pfun A B = {R. R \<in> A \<leftrightarrow> B \<and> functional R}" \<comment> \<open> Partial Functions \<close>

lemma rel_pfun_intro: "\<lbrakk> R \<in> A \<leftrightarrow> B; functional R \<rbrakk> \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_pfun_def)

definition rel_tfun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>t" 55) where
"rel_tfun A B = {R. R \<in> A \<rightarrow>\<^sub>p B \<and> left_totalr R}" \<comment> \<open> Total Functions \<close>

definition rel_ffun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>f" 55) where
"rel_ffun A B = {R. R \<in> A \<rightarrow>\<^sub>p B \<and> finite(Domain R)}" \<comment> \<open> Finite Functions \<close>

subsection \<open> Closure Properties \<close>

text \<open> These can be seen as typing rules for relational functions \<close>

named_theorems rclos

lemma rel_ffun_is_pfun [rclos]: "R \<in> rel_ffun A B \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_ffun_def)

lemma rel_tfun_is_pfun [rclos]: "R \<in> A \<rightarrow>\<^sub>t B \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_tfun_def)

lemma rel_pfun_is_typed [rclos]: "R \<in> A \<rightarrow>\<^sub>p B \<Longrightarrow> R \<in> A \<leftrightarrow> B"
  by (simp add: rel_pfun_def)

lemma rel_ffun_empty [rclos]: "{} \<in> rel_ffun A B"
  by (simp add: rel_ffun_def rel_pfun_def rel_typed_def)

lemma rel_pfun_apply [rclos]: "\<lbrakk> x \<in> Domain(R); R \<in> A \<rightarrow>\<^sub>p B \<rbrakk> \<Longrightarrow> R(x)\<^sub>r \<in> B"
  using functional_apply by (fastforce simp add: rel_pfun_def rel_typed_def)

lemma rel_tfun_apply [rclos]: "\<lbrakk> x \<in> A; R \<in> A \<rightarrow>\<^sub>t B \<rbrakk> \<Longrightarrow> R(x)\<^sub>r \<in> B"
  by (metis (no_types, lifting) Domain_iff iso_tuple_UNIV_I left_totalr_on_def mem_Collect_eq rel_pfun_apply rel_tfun_def)

lemma rel_typed_insert [rclos]: "\<lbrakk> R \<in> A \<leftrightarrow> B; x \<in> A; y \<in> B \<rbrakk> \<Longrightarrow> insert (x, y) R \<in> A \<leftrightarrow> B"
  by (simp add: rel_typed_def)

lemma rel_pfun_insert [rclos]: "\<lbrakk> R \<in> A \<rightarrow>\<^sub>p B; x \<in> A; y \<in> B; x \<notin> Domain(R) \<rbrakk> \<Longrightarrow> insert (x, y) R \<in> A \<rightarrow>\<^sub>p B"
  by (auto intro: rclos simp add: rel_pfun_def)

lemma rel_pfun_override [rclos]: "\<lbrakk> R \<in> A \<rightarrow>\<^sub>p B; S \<in> A \<rightarrow>\<^sub>p B \<rbrakk> \<Longrightarrow> (R \<oplus> S) \<in> A \<rightarrow>\<^sub>p B"
  apply (rule rel_pfun_intro)
   apply (rule rel_typed_intro)
  apply (auto simp add: rel_pfun_def rel_typed_def)
  apply (metis (no_types, opaque_lifting) Range.simps Range_Un_eq Range_rel_override Un_iff rev_subsetD)
  done

subsection \<open> Code Generation \<close>

lemma rel_conv_alist [code]: "(set xs)\<inverse> = set (map (\<lambda>(x, y). (y, x)) xs)"
  by (induct xs, auto)

lemma rel_domres_alist [code]: "A \<lhd>\<^sub>r set xs = set (AList.restrict A xs)"
  by (induct xs, simp_all, safe, simp_all)

lemma Image_alist [code]: "set xs `` A = set (map snd (AList.restrict A xs))"
  by (simp add: Image_as_rel_domres rel_domres_alist Range_snd)

lemma Collect_set: "{x \<in> set xs. P x} = set (filter P xs)"
  by auto

lemma single_valued_dom_alist [code]:
  "single_valued_dom (set xs) = set (filter (\<lambda>x. length (remdups (map snd (AList.restrict {x} xs))) = 1) (map fst xs))"
  by (simp only: single_valued_dom_def set_map[THEN sym] Image_alist Domain_set set_singleton_iff list_singleton_iff Collect_set)

lemma AList_restrict_in_dom: "AList.restrict (set (filter P (map fst xs))) xs = filter (\<lambda> (x, y). P x) xs"
  by (auto intro: filter_cong simp add: Domain.intros fst_eq_Domain AList.restrict_eq)

lemma mk_functional_alist [code]:
  "mk_functional (set xs) = set (filter (\<lambda> (x,y). length (remdups (map snd (AList.restrict {x} xs))) = 1) xs)"
  by (simp only: mk_functional_single_valued_dom rel_domres_alist single_valued_dom_alist AList_restrict_in_dom)

lemma rel_apply_set [code]:
  "rel_apply (set xs) k =
  (let ys = filter (\<lambda> (k', v). k = k') xs in
   if (length ys > 0 \<and> ys = replicate (length ys) (hd ys)) then snd (hd ys) else undefined)"
proof (simp add: Let_unfold, safe)
  let ?ys = "filter (\<lambda>(k', v). k = k') xs"
  assume ys: "?ys \<noteq> []" "?ys = replicate (length ?ys) (hd ?ys)"
  have kmem: "\<And> y. (k, y) \<in> set xs \<longleftrightarrow> (k, y) \<in> set ?ys"
    by simp
  from ys obtain v where v: "(k, v) \<in> set xs"
    using hd_in_set by fastforce
  hence ys':"?ys = replicate (length ?ys) (k, v)"
    by (metis (mono_tags) case_prodI filter_set in_set_replicate member_filter ys(2))
  hence "snd (hd ?ys) = v"
    by (metis hd_replicate replicate_0 snd_conv ys(1))
  moreover have "(THE y. (k, y) \<in> set xs) = v"
    by (metis (no_types, lifting) v in_set_replicate kmem snd_conv the_equality ys')
  moreover have "(\<exists>!y. (k, y) \<in> set xs)"
    by (metis Pair_inject v in_set_replicate kmem ys')
  ultimately show "set xs(k)\<^sub>r = snd (hd ?ys)"
    by (simp add: rel_apply_def)
next
  assume "filter (\<lambda>(k', v). k = k') xs = []"
  hence "\<nexists>v. (k, v) \<in> set xs"
    by (metis (mono_tags, lifting) case_prodI filter_empty_conv)
  thus "set xs(k)\<^sub>r = undefined"
    by (auto simp add: rel_apply_def)
next
  let ?ys = "filter (\<lambda>(k', v). k = k') xs"
  assume ys: "?ys \<noteq> replicate (length ?ys) (hd ?ys)"
  have keys: "\<forall> (k', v') \<in> set ?ys. k' = k"
    by auto
  show "set xs(k)\<^sub>r = undefined"
  proof (cases "length ?ys = 0")
    case True
    then show ?thesis
      using ys by fastforce
  next
    case False
    hence "length ?ys > 1"
      by (metis hd_in_set in_set_conv_nth length_0_conv less_one linorder_neqE_nat replicate_length_same ys)
    have "fst (hd ?ys) = k"
      using False hd_in_set by force
    have "\<not>(\<forall> (k, v) \<in> set ?ys. v = snd (hd ?ys))"
    proof
      assume "(\<forall> (k, v) \<in> set ?ys. v = snd (hd ?ys))"
      hence "(\<forall> p \<in> set ?ys. p = (k, snd (hd ?ys)))"
        by fastforce
      hence "?ys = replicate (length ?ys) (hd ?ys)"
        by (metis False length_0_conv list.set_sel(1) replicate_length_same)
      thus False
        using ys by blast
    qed
    then obtain v where "(k, v) \<in> set ?ys" "v \<noteq> snd (hd ?ys)"
      by fastforce
    hence "(\<not> (\<exists>!y. (k, y) \<in> set xs))"
      using False list.set_sel(1) by fastforce
    then show ?thesis
      by (simp add: rel_apply_def)
  qed
qed

end


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

section\<open>Relations: Their General Properties and Transitive Closure\<close>

theory Trancl imports Fixedpt Perm begin

definition
  refl     :: "[i,i]=>o"  where
    "refl(A,r) == (\<forall>x\<in>A. <x,x> \<in> r)"

definition
  irrefl   :: "[i,i]=>o"  where
    "irrefl(A,r) == \<forall>x\<in>A. <x,x> \<notin> r"

definition
  sym      :: "i=>o"  where
    "sym(r) == \<forall>x y. <x,y>: r \<longrightarrow> <y,x>: r"

definition
  asym     :: "i=>o"  where
    "asym(r) == \<forall>x y. <x,y>:r \<longrightarrow> ~ <y,x>:r"

definition
  antisym  :: "i=>o"  where
    "antisym(r) == \<forall>x y.<x,y>:r \<longrightarrow> <y,x>:r \<longrightarrow> x=y"

definition
  trans    :: "i=>o"  where
    "trans(r) == \<forall>x y z. <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  trans_on :: "[i,i]=>o"  ("trans[_]'(_')")  where
    "trans[A](r) == \<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A.
                          <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  rtrancl :: "i=>i"  ("(_^*)" [100] 100)  (*refl/transitive closure*)  where
    "r^* == lfp(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"

definition
  trancl  :: "i=>i"  ("(_^+)" [100] 100)  (*transitive closure*)  where
    "r^+ == r O r^*"

definition
  equiv    :: "[i,i]=>o"  where
    "equiv(A,r) == r \<subseteq> A*A & refl(A,r) & sym(r) & trans(r)"

subsection\<open>General properties of relations\<close>

subsubsection\<open>irreflexivity\<close>

lemma irreflI:
    "[| !!x. x \<in> A ==> <x,x> \<notin> r |] ==> irrefl(A,r)"
by (simp add: irrefl_def)

lemma irreflE: "[| irrefl(A,r);  x \<in> A |] ==>  <x,x> \<notin> r"
by (simp add: irrefl_def)

subsubsection\<open>symmetry\<close>

lemma symI:
     "[| !!x y.<x,y>: r ==> <y,x>: r |] ==> sym(r)"
by (unfold sym_def, blast)

lemma symE: "[| sym(r); <x,y>: r |]  ==>  <y,x>: r"
by (unfold sym_def, blast)

subsubsection\<open>antisymmetry\<close>

lemma antisymI:
     "[| !!x y.[| <x,y>: r;  <y,x>: r |] ==> x=y |] ==> antisym(r)"
by (simp add: antisym_def, blast)

lemma antisymE: "[| antisym(r); <x,y>: r;  <y,x>: r |]  ==>  x=y"
by (simp add: antisym_def, blast)

subsubsection\<open>transitivity\<close>

lemma transD: "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r"
by (unfold trans_def, blast)

lemma trans_onD:
    "[| trans[A](r);  <a,b>:r;  <b,c>:r;  a \<in> A;  b \<in> A;  c \<in> A |] ==> <a,c>:r"
by (unfold trans_on_def, blast)

lemma trans_imp_trans_on: "trans(r) ==> trans[A](r)"
by (unfold trans_def trans_on_def, blast)

lemma trans_on_imp_trans: "[|trans[A](r); r \<subseteq> A*A|] ==> trans(r)"
by (simp add: trans_on_def trans_def, blast)

subsection\<open>Transitive closure of a relation\<close>

lemma rtrancl_bnd_mono:
     "bnd_mono(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"
by (rule bnd_monoI, blast+)

lemma rtrancl_mono: "r<=s ==> r^* \<subseteq> s^*"
apply (unfold rtrancl_def)
apply (rule lfp_mono)
apply (rule rtrancl_bnd_mono)+
apply blast
done

(* @{term"r^* = id(field(r)) \<union> ( r O r^* )"}    *)
lemmas rtrancl_unfold =
     rtrancl_bnd_mono [THEN rtrancl_def [THEN def_lfp_unfold]]

(** The relation rtrancl **)

(*  @{term"r^* \<subseteq> field(r) * field(r)"}  *)
lemmas rtrancl_type = rtrancl_def [THEN def_lfp_subset]

lemma relation_rtrancl: "relation(r^*)"
apply (simp add: relation_def)
apply (blast dest: rtrancl_type [THEN subsetD])
done

(*Reflexivity of rtrancl*)
lemma rtrancl_refl: "[| a \<in> field(r) |] ==> <a,a> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (erule idI [THEN UnI1])
done

(*Closure under composition with r  *)
lemma rtrancl_into_rtrancl: "[| <a,b> \<in> r^*;  <b,c> \<in> r |] ==> <a,c> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (rule compI [THEN UnI2], assumption, assumption)
done

(*rtrancl of r contains all pairs in r  *)
lemma r_into_rtrancl: "<a,b> \<in> r ==> <a,b> \<in> r^*"
by (rule rtrancl_refl [THEN rtrancl_into_rtrancl], blast+)

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_rtrancl: "relation(r) ==> r \<subseteq> r^*"
by (simp add: relation_def, blast intro: r_into_rtrancl)

lemma rtrancl_field: "field(r^*) = field(r)"
by (blast intro: r_into_rtrancl dest!: rtrancl_type [THEN subsetD])

(** standard induction rule **)

lemma rtrancl_full_induct [case_names initial step, consumes 1]:
  "[| <a,b> \<in> r^*;
      !!x. x \<in> field(r) ==> P(<x,x>);
      !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |]
   ==>  P(<a,b>)"
by (erule def_induct [OF rtrancl_def rtrancl_bnd_mono], blast)

(*nice induction rule.
  Tried adding the typing hypotheses y,z \<in> field(r), but these
  caused expensive case splits!*)
lemma rtrancl_induct [case_names initial step, induct set: rtrancl]:
  "[| <a,b> \<in> r^*;
      P(a);
      !!y z.[| <a,y> \<in> r^*;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
(*by induction on this formula*)
apply (subgoal_tac "\<forall>y. <a,b> = <a,y> \<longrightarrow> P (y) ")
(*now solve first subgoal: this formula is sufficient*)
apply (erule spec [THEN mp], rule refl)
(*now do the induction*)
apply (erule rtrancl_full_induct, blast+)
done

(*transitivity of transitive closure!! -- by induction.*)
lemma trans_rtrancl: "trans(r^*)"
apply (unfold trans_def)
apply (intro allI impI)
apply (erule_tac b = z in rtrancl_induct, assumption)
apply (blast intro: rtrancl_into_rtrancl)
done

lemmas rtrancl_trans = trans_rtrancl [THEN transD]

(*elimination of rtrancl -- by induction on a special formula*)
lemma rtranclE:
    "[| <a,b> \<in> r^*;  (a=b) ==> P;
        !!y.[| <a,y> \<in> r^*;   <y,b> \<in> r |] ==> P |]
     ==> P"
apply (subgoal_tac "a = b | (\<exists>y. <a,y> \<in> r^* & <y,b> \<in> r) ")
(*see HOL/trancl*)
apply blast
apply (erule rtrancl_induct, blast+)
done

(**** The relation trancl ****)

(*Transitivity of r^+ is proved by transitivity of r^*  *)
lemma trans_trancl: "trans(r^+)"
apply (unfold trans_def trancl_def)
apply (blast intro: rtrancl_into_rtrancl
                    trans_rtrancl [THEN transD, THEN compI])
done

lemmas trans_on_trancl = trans_trancl [THEN trans_imp_trans_on]

lemmas trancl_trans = trans_trancl [THEN transD]

(** Conversions between trancl and rtrancl **)

lemma trancl_into_rtrancl: "<a,b> \<in> r^+ ==> <a,b> \<in> r^*"
apply (unfold trancl_def)
apply (blast intro: rtrancl_into_rtrancl)
done

(*r^+ contains all pairs in r  *)
lemma r_into_trancl: "<a,b> \<in> r ==> <a,b> \<in> r^+"
apply (unfold trancl_def)
apply (blast intro!: rtrancl_refl)
done

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_trancl: "relation(r) ==> r \<subseteq> r^+"
by (simp add: relation_def, blast intro: r_into_trancl)

(*intro rule by definition: from r^* and r  *)
lemma rtrancl_into_trancl1: "[| <a,b> \<in> r^*;  <b,c> \<in> r |]   ==>  <a,c> \<in> r^+"
by (unfold trancl_def, blast)

(*intro rule from r and r^*  *)
lemma rtrancl_into_trancl2:
    "[| <a,b> \<in> r;  <b,c> \<in> r^* |]   ==>  <a,c> \<in> r^+"
apply (erule rtrancl_induct)
 apply (erule r_into_trancl)
apply (blast intro: r_into_trancl trancl_trans)
done

(*Nice induction rule for trancl*)
lemma trancl_induct [case_names initial step, induct set: trancl]:
  "[| <a,b> \<in> r^+;
      !!y.  [| <a,y> \<in> r |] ==> P(y);
      !!y z.[| <a,y> \<in> r^+;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
apply (rule compEpair)
apply (unfold trancl_def, assumption)
(*by induction on this formula*)
apply (subgoal_tac "\<forall>z. <y,z> \<in> r \<longrightarrow> P (z) ")
(*now solve first subgoal: this formula is sufficient*)
 apply blast
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_into_trancl1)+
done

(*elimination of r^+ -- NOT an induction rule*)
lemma tranclE:
    "[| <a,b> \<in> r^+;
        <a,b> \<in> r ==> P;
        !!y.[| <a,y> \<in> r^+; <y,b> \<in> r |] ==> P
     |] ==> P"
apply (subgoal_tac "<a,b> \<in> r | (\<exists>y. <a,y> \<in> r^+ & <y,b> \<in> r) ")
apply blast
apply (rule compEpair)
apply (unfold trancl_def, assumption)
apply (erule rtranclE)
apply (blast intro: rtrancl_into_trancl1)+
done

lemma trancl_type: "r^+ \<subseteq> field(r)*field(r)"
apply (unfold trancl_def)
apply (blast elim: rtrancl_type [THEN subsetD, THEN SigmaE2])
done

lemma relation_trancl: "relation(r^+)"
apply (simp add: relation_def)
apply (blast dest: trancl_type [THEN subsetD])
done

lemma trancl_subset_times: "r \<subseteq> A * A ==> r^+ \<subseteq> A * A"
by (insert trancl_type [of r], blast)

lemma trancl_mono: "r<=s ==> r^+ \<subseteq> s^+"
by (unfold trancl_def, intro comp_mono rtrancl_mono)

lemma trancl_eq_r: "[|relation(r); trans(r)|] ==> r^+ = r"
apply (rule equalityI)
 prefer 2 apply (erule r_subset_trancl, clarify)
apply (frule trancl_type [THEN subsetD], clarify)
apply (erule trancl_induct, assumption)
apply (blast dest: transD)
done

(** Suggested by Sidi Ould Ehmety **)

lemma rtrancl_idemp [simp]: "(r^*)^* = r^*"
apply (rule equalityI, auto)
 prefer 2
 apply (frule rtrancl_type [THEN subsetD])
 apply (blast intro: r_into_rtrancl )
txt\<open>converse direction\<close>
apply (frule rtrancl_type [THEN subsetD], clarify)
apply (erule rtrancl_induct)
apply (simp add: rtrancl_refl rtrancl_field)
apply (blast intro: rtrancl_trans)
done

lemma rtrancl_subset: "[| R \<subseteq> S; S \<subseteq> R^* |] ==> S^* = R^*"
apply (drule rtrancl_mono)
apply (drule rtrancl_mono, simp_all, blast)
done

lemma rtrancl_Un_rtrancl:
     "[| relation(r); relation(s) |] ==> (r^* \<union> s^*)^* = (r \<union> s)^*"
apply (rule rtrancl_subset)
apply (blast dest: r_subset_rtrancl)
apply (blast intro: rtrancl_mono [THEN subsetD])
done

(*** "converse" laws by Sidi Ould Ehmety ***)

(** rtrancl **)

lemma rtrancl_converseD: "<x,y>:converse(r)^* ==> <x,y>:converse(r^*)"
apply (rule converseI)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converseI: "<x,y>:converse(r^*) ==> <x,y>:converse(r)^*"
apply (drule converseD)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converse: "converse(r)^* = converse(r^*)"
apply (safe intro!: equalityI)
apply (frule rtrancl_type [THEN subsetD])
apply (safe dest!: rtrancl_converseD intro!: rtrancl_converseI)
done

(** trancl **)

lemma trancl_converseD: "<a, b>:converse(r)^+ ==> <a, b>:converse(r^+)"
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converseI: "<x,y>:converse(r^+) ==> <x,y>:converse(r)^+"
apply (drule converseD)
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converse: "converse(r)^+ = converse(r^+)"
apply (safe intro!: equalityI)
apply (frule trancl_type [THEN subsetD])
apply (safe dest!: trancl_converseD intro!: trancl_converseI)
done

lemma converse_trancl_induct [case_names initial step, consumes 1]:
"[| <a, b>:r^+; !!y. <y, b> :r ==> P(y);
      !!y z. [| <y, z> \<in> r; <z, b> \<in> r^+; P(z) |] ==> P(y) |]
       ==> P(a)"
apply (drule converseI)
apply (simp (no_asm_use) add: trancl_converse [symmetric])
apply (erule trancl_induct)
apply (auto simp add: trancl_converse)
done

end


header {* General purpose definitions and lemmas *}

theory JHelper imports
  Main
begin

lemma Collect_iff:
  "a \<in> {x . P x} \<equiv> P a"
by auto

lemma diff_diff_eq:
  assumes "C \<subseteq> B"
  shows "(A - C) - (B - C) = A - B"
using assms by auto

lemma nth_in_set:
  "\<lbrakk> i < length xs ; xs ! i = x \<rbrakk> \<Longrightarrow> x \<in> set xs" by auto

lemma disjI [intro]:
  assumes "\<not> P \<Longrightarrow> Q"
  shows "P \<or> Q"
using assms by auto

lemma empty_eq_Plus_conv:
  "({} = A <+> B) = (A = {} \<and> B = {})"
by auto

subsection {* Projection functions on triples *}

definition fst3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'a"
where "fst3 \<equiv> fst"

definition snd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'b"
where "snd3 \<equiv> fst \<circ> snd"

definition thd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'c"
where "thd3 \<equiv> snd \<circ> snd"

lemma fst3_simp:
  "\<And>a b c. fst3 (a,b,c) = a"
by (auto simp add: fst3_def)

lemma snd3_simp:
  "\<And>a b c. snd3 (a,b,c) = b"
by (auto simp add: snd3_def)

lemma thd3_simp:
  "\<And>a b c. thd3 (a,b,c) = c"
by (auto simp add: thd3_def)

lemma tripleI:
  fixes T U
  assumes "fst3 T = fst3 U"
      and "snd3 T = snd3 U"
      and "thd3 T = thd3 U"
  shows "T = U"
by (metis assms fst3_def snd3_def thd3_def o_def surjective_pairing)

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>The Category of Measurable Spaces is not Cartesian Closed\<close>

theory Measure_Not_CCC
  imports "~~/src/HOL/Probability/Probability"
begin

text \<open>
  We show that the category of measurable spaces with measurable functions as morphisms is not a
  Cartesian closed category. While the category has products and terminal objects, the exponential
  does not exist for each pair of measurable spaces.

  We show that the exponential $\mathbb{B}^\mathbb{C}$ does not exist, where $\mathbb{B}$ is the
  discrete measurable space on boolean values, and $\mathbb{C}$ is the $\sigma$-algebra consisting
  of all countable and co-countable real sets. We also define $\mathbb{R}$ to be the discrete
  measurable space on the reals.

  Now, the diagonal predicate @{term "\<lambda>x y. x = y"} is $\mathbb{R}$-$\mathbb{B}^\mathbb{C}$-measurable,
  but @{term "\<lambda>(x, y). x = y"} is not $(\mathbb{R} \times \mathbb{C})$-$\mathbb{B}$-measurable.
\<close>

definition COCOUNT :: "real measure" where
  "COCOUNT = sigma UNIV {{x} | x. True}"

abbreviation POW :: "real measure" where
  "POW \<equiv> count_space UNIV"

abbreviation BOOL :: "bool measure" where
  "BOOL \<equiv> count_space UNIV"

lemma measurable_const_iff: "(\<lambda>x. c) \<in> measurable A B \<longleftrightarrow> (space A = {} \<or> c \<in> space B)"
  by (auto simp: measurable_def)

lemma measurable_eq[measurable]: "(op = x) \<in> measurable COCOUNT BOOL"
  unfolding pred_def by (auto simp: COCOUNT_def)

lemma COCOUNT_eq: "A \<in> COCOUNT \<longleftrightarrow> countable A \<or> countable (UNIV - A)"
proof
  fix A assume "A \<in> COCOUNT"
  then have "A \<in> sigma_sets UNIV {{x} | x. True}"
    by (auto simp: COCOUNT_def)
  then show "countable A \<or> countable (UNIV - A)"
  proof induction
    case (Union F)
    moreover
    { fix i assume "countable (UNIV - F i)"
      then have "countable (UNIV - (\<Union>i. F i))"
        by (rule countable_subset[rotated]) auto }
    ultimately show "countable (\<Union>i. F i) \<or> countable (UNIV - (\<Union>i. F i))"
      by blast
  qed (auto simp: Diff_Diff_Int)
next
  assume "countable A \<or> countable (UNIV - A)"
  moreover
  { fix A :: "real set" assume A: "countable A"
    have "A = (\<Union>a\<in>A. {a})"
      by auto
    also have "\<dots> \<in> COCOUNT"
      by (intro sets.countable_UN' A) (auto simp: COCOUNT_def)
    finally have "A \<in> COCOUNT" . }
  note A = this
  note A[of A]
  moreover
  { assume "countable (UNIV - A)"
    with A have "space COCOUNT - (UNIV - A) \<in> COCOUNT" by simp
    then have "A \<in> COCOUNT"
      by (auto simp: COCOUNT_def Diff_Diff_Int) }
  ultimately show "A \<in> COCOUNT"
    by blast
qed

lemma pair_COCOUNT:
  assumes A: "A \<in> sets (COCOUNT \<Otimes>\<^sub>M M)"
  shows "\<exists>J F X. X \<in> sets M \<and> F \<in> J \<rightarrow> sets M \<and> countable J \<and> A = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
  using A unfolding sets_pair_measure
proof induction
  case (Basic X)
  then obtain a b where X: "X = a \<times> b" and b: "b \<in> sets M" and a: "countable a \<or> countable (UNIV - a)"
    by (auto simp: COCOUNT_eq)
  from a show ?case
  proof
    assume "countable a" with X b show ?thesis
      by (intro exI[of _ a] exI[of _ "\<lambda>_. b"] exI[of _ "{}"]) auto
  next
    assume "countable (UNIV - a)" with X b show ?thesis
      by (intro exI[of _ "UNIV - a"] exI[of _ "\<lambda>_. {}"] exI[of _ "b"]) auto
  qed
next
  case Empty then show ?case
    by (intro exI[of _ "{}"] exI[of _ "\<lambda>_. {}"] exI[of _ "{}"]) auto
next
  case (Compl A)
  then obtain J F X where XFJ: "X \<in> sets M" "F \<in> J \<rightarrow> sets M" "countable J"
    and A: "A = (UNIV - J) \<times> X \<union> Sigma J F"
    by auto
  have *: "space COCOUNT \<times> space M - A = (UNIV - J) \<times> (space M - X) \<union> (SIGMA j:J. space M - F j)"
    unfolding A by (auto simp: COCOUNT_def)
  show ?case
    using XFJ unfolding *
    by (intro exI[of _ J] exI[of _ "space M - X"] exI[of _ "\<lambda>j. space M - F j"]) auto
next
  case (Union A)
  obtain J F X where XFJ: "\<And>i. X i \<in> sets M" "\<And>i. F i \<in> J i \<rightarrow> sets M" "\<And>i. countable (J i)"
    and A_eq: "A = (\<lambda>i. (UNIV - J i) \<times> X i \<union> Sigma (J i) (F i))"
    unfolding fun_eq_iff using Union.IH by metis
  show ?case
  proof (intro exI conjI)
    define G where "G j = (\<Union>i. if j \<in> J i then F i j else X i)" for j
    show "(\<Union>i. X i) \<in> sets M" "countable (\<Union>i. J i)" "G \<in> (\<Union>i. J i) \<rightarrow> sets M"
      using XFJ by (auto simp: G_def Pi_iff)
    show "UNION UNIV A = (UNIV - (\<Union>i. J i)) \<times> (\<Union>i. X i) \<union> (SIGMA j:\<Union>i. J i. \<Union>i. if j \<in> J i then F i j else X i)"
      unfolding A_eq by (auto split: if_split_asm)
  qed
qed

context
  fixes EXP :: "(real \<Rightarrow> bool) measure"
  assumes eq: "\<And>P. case_prod P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP"
begin

lemma space_EXP: "space EXP = measurable COCOUNT BOOL"
proof -
  { fix f
    have "f \<in> space EXP \<longleftrightarrow> (\<lambda>(a, b). f b) \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL"
      using eq[of "\<lambda>x. f"] by (simp add: measurable_const_iff)
    also have "\<dots> \<longleftrightarrow> f \<in> measurable COCOUNT BOOL"
      by auto
    finally have "f \<in> space EXP \<longleftrightarrow> f \<in> measurable COCOUNT BOOL" . }
  then show ?thesis by auto
qed

lemma measurable_eq_EXP: "(\<lambda>x y. x = y) \<in> measurable POW EXP"
  unfolding measurable_def by (auto simp: space_EXP)

lemma measurable_eq_pair: "(\<lambda>(y, x). x = y) \<in> measurable (COCOUNT \<Otimes>\<^sub>M POW) BOOL"
  using measurable_eq_EXP unfolding eq[symmetric]
  by (subst measurable_pair_swap_iff) simp

lemma ce: False
proof -
  have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} \<in> sets (COCOUNT \<Otimes>\<^sub>M POW)"
    using measurable_eq_pair unfolding pred_def by (simp add: split_beta')
  also have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} = (SIGMA j:UNIV. {j})"
    by (auto simp: space_pair_measure COCOUNT_def)
  finally obtain X F J where "countable (J::real set)"
    and eq: "(SIGMA j:UNIV. {j}) = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
    using pair_COCOUNT[of "SIGMA j:UNIV. {j}" POW] by auto
  have X_single: "\<And>x. x \<notin> J \<Longrightarrow> X = {x}"
    using eq[unfolded set_eq_iff] by force

  have "uncountable (UNIV - J)"
    using \<open>countable J\<close> uncountable_UNIV_real uncountable_minus_countable by blast
  then have "infinite (UNIV - J)"
    by (auto intro: countable_finite)
  then have "\<exists>A. finite A \<and> card A = 2 \<and> A \<subseteq> UNIV - J"
    by (rule infinite_arbitrarily_large)
  then obtain i j where ij: "i \<in> UNIV - J" "j \<in> UNIV - J" "i \<noteq> j"
    by (auto simp add: card_Suc_eq numeral_2_eq_2)
  have "{(i, i), (j, j)} \<subseteq> (SIGMA j:UNIV. {j})" by auto
  with ij X_single[of i] X_single[of j] show False
    by auto
qed

end

corollary "\<not> (\<exists>EXP. \<forall>P. case_prod P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP)"
  using ce by blast

end