(*
  File:    Harmonic_2_adic.thy
  Author:  Jose Manuel Rodriguez Caballero, University of Tartu
  Author:  Manuel Eberl, TU München
*)
section \<open>Applications of the p-adic norm to the harmonic numbers\<close>
theory Harmonic_2_adic

imports
  "HOL-Analysis.Harmonic_Numbers"
  Pnorm

begin

text \<open>
 In 1915, L. Theisinger ~\cite{theisinger1915bemerkung} proved that, for \<^term>\<open>(n::nat) \<ge> 2\<close>, the
 harmonic number \<^term>\<open>(harm n) :: real\<close> is not an integer. In 1918,  J. K{\"u}rsch{\'a}k
 ~\cite{kurschak1918harmonic} proved that, for \<^term>\<open>(n::nat)+2 \<ge> (m::nat)\<close>, the difference between
 the two harmonic numbers \<^term>\<open>((harm n) - (harm m))::real\<close> is not an integer. We formalize these
 results as theorems @{text Taeisinger} and @{text Kurschak}, respectively. The proofs will be
 simple consequences the computation of the 2-adic norm of the harmonic numbers
 (lemma @{text harmonic_numbers_2norm}).
\<close>

subsection \<open>Auxiliary results\<close>
text\<open>
  The following function is a variation of \<^term>\<open>harm\<close>, where the codomain is typ>\<open>rat\<close>. We need this
  function because the codomain of \<^term>\<open>harm\<close> cannot be \<^typ>\<open>rat\<close>.
\<close>
fun Harm :: "nat \<Rightarrow> rat" where
  "Harm 0 = 0" |
  "Harm (Suc n) = Harm n + inverse (of_nat (Suc n))"

lemma Harm'[simp]: "real_of_rat (Harm n) = harm n"
proof(induction n)
  case 0 thus ?case by (simp add: harm_expand(1))
next
  case (Suc n)
  have "real_of_rat (Harm (Suc n)) = real_of_rat (Harm n + inverse (of_nat (Suc n)))"
    by simp
  also have "\<dots> = real_of_rat (Harm n) + real_of_rat (inverse (of_nat (Suc n)))"
    by (simp add: of_rat_add)
  also have "\<dots> = harm n + real_of_rat (inverse (of_nat (Suc n)))"
    by (simp add: Suc.IH)
  finally show ?case
    by (metis harm_Suc of_rat_inverse of_rat_of_nat_eq)
qed

lemma harm_diff_plus:
  "harm (n+t) - harm n = (\<Sum>k=n+1..n+t. inverse (of_nat k))"
proof(induct t)
  case 0 thus ?case by simp
next
  case (Suc t) show ?case
  proof -
    have f1: "\<forall>a b c. (a::'a) + b \<noteq> a + c \<or> b = c"
      by (meson add_left_imp_eq)
    have f2: "(\<Sum>n = 1..n. inverse (of_nat n::'a)) + (harm (n + Suc t) - harm n)
            = (\<Sum>n = 1..n + Suc t. inverse (of_nat n))"
      by (metis (no_types) add.commute diff_add_cancel harm_def)
    have "(\<Sum>n = 1..n + Suc t. inverse (of_nat n::'a))
        = (\<Sum>n = 1..n. inverse (of_nat n)) + (\<Sum>n = n + 1..n + Suc t. inverse (of_nat n))"
      by (meson le_add2 sum.ub_add_nat)
    thus ?thesis
      using f2 f1 by presburger
  qed
qed

lemma harm_diff:
  "n \<ge> m \<Longrightarrow> harm n - harm m = (\<Sum>k=m+1..n. inverse (of_nat k))"
  using harm_diff_plus[where n = m and t = "n - m"] by simp

lemma harm_diff':
  "n \<ge> m \<Longrightarrow> Harm n - Harm m = (\<Sum>k=m+1..n. inverse (rat_of_nat k))"
proof-
  assume "n \<ge> m"
  have "real_of_rat (Harm n - Harm m) = harm n - harm m"
    by (simp add: of_rat_diff)
  also have "\<dots> = (\<Sum>k=m+1..n. inverse (of_nat k))"
    using harm_diff \<open>m \<le> n\<close> by blast
  also have "\<dots> = (\<Sum>k=m+1..n. real_of_rat (inverse (rat_of_nat k)))"
    by (simp add: of_rat_inverse)
  also have "\<dots> = real_of_rat (\<Sum>k=m+1..n. (inverse (rat_of_nat k)))"
    by (simp add: of_rat_sum)
  finally show ?thesis by auto
qed

lemma Harm_explicit:
  "Harm n = (\<Sum>k=1..n. inverse (rat_of_nat k))"
  using harm_diff' by fastforce

lemma Harm_incre: \<open>m < n \<Longrightarrow> Harm m < Harm n\<close>
proof-
  assume \<open>m < n\<close>
  have \<open>finite {m + 1..n}\<close>
    by simp
  moreover have \<open>{m + 1..n} \<noteq> {}\<close>
    using \<open>m < n\<close>
    by simp
  moreover have \<open>k \<in> {m + 1..n} \<Longrightarrow> 0 < inverse (rat_of_nat k)\<close> for k
  proof-
    assume \<open>k \<in> {m + 1..n}\<close>
    hence \<open>k \<ge> 1\<close>
      by auto
    thus ?thesis
      by (simp add: zero_less_Fract_iff)
  qed
  ultimately have \<open>0 < (\<Sum>k = m + 1..n. inverse (rat_of_nat k))\<close>
    using Groups_Big.ordered_comm_monoid_add_class.sum_pos[where I = "{m+1..n}"
        and f = "\<lambda> k. inverse (rat_of_nat k)"] by auto
  thus ?thesis
    using harm_diff'[where n = n and m = m] \<open>n > m\<close>
    by simp
qed

lemma Harm_diff_less_1:
  "m < n \<Longrightarrow> n \<le> 2*m \<Longrightarrow> Harm n - Harm m < 1"
proof-
  assume "m < n" and "n \<le> 2*m"
  have \<open>(\<Sum>k = m + 1..n. inverse (rat_of_nat k)) < 1\<close>
  proof-
    have \<open>finite {m + 1..n}\<close>
      by simp
    moreover have \<open>{m + 1..n} \<noteq> {}\<close>
      using \<open>m < n\<close> by simp
    moreover have \<open>k \<in> {m + 1..n} \<Longrightarrow> inverse (rat_of_nat k) \<le> inverse (rat_of_nat (m+1))\<close> for k
    proof-
      assume \<open>k \<in> {m + 1..n}\<close>
      have \<open>k \<ge> m+1\<close>
        using \<open>k \<in> {m + 1..n}\<close>
        by auto
      thus ?thesis
        by auto
    qed
    ultimately have \<open>(\<Sum>k = m + 1..n. inverse (rat_of_nat k))
                     \<le> of_nat (card {m + 1..n}) * inverse (rat_of_nat (m+1))\<close>
      using Groups_Big.sum_bounded_above[where A = "{m+1..n}" and K = "inverse (rat_of_nat (m+1))"
          and f = "\<lambda> k. inverse (rat_of_nat k)"]
      by auto
    also  have \<open>\<dots> \<le> of_nat m * inverse (rat_of_nat (m+1))\<close>
    proof-
      have \<open>card {m+1..n} \<le> m\<close>
      proof-
        have \<open>card {m+1..n} = n - m\<close>
          by auto
        thus ?thesis
          using \<open>n \<le> 2*m\<close> by simp
      qed
      moreover have \<open>card  {m + 1..n} > 0\<close>
        using \<open>{m + 1..n} \<noteq> {}\<close> card_gt_0_iff by blast
      ultimately show ?thesis by simp
    qed
    also have \<open>\<dots> < 1\<close>
    proof -
      have f1: "0 < Fract 1 (int (m + 1))"
        using zero_less_Fract_iff by auto
      have "rat_of_nat (m + 1) * inverse (rat_of_nat (m + 1)) = 1"
        by auto
      thus ?thesis
        using f1 by (metis (no_types) Fract_of_nat_eq inverse_rat less_add_same_cancel1 less_one
            linordered_field_class.sign_simps(35) linordered_field_class.sign_simps(44)
            of_nat_0_less_iff of_nat_add)
    qed
    finally show ?thesis
      by blast
  qed
  thus ?thesis
    using harm_diff' \<open>m < n\<close> by auto
qed

(* TODO: delete *)
lemma sum_last:
  fixes n::nat and a::\<open>nat \<Rightarrow> rat\<close>
  assumes \<open>n \<ge> 2\<close>
  shows \<open>(\<Sum>k = 1..n - 1. (a k)) + (a n) = (\<Sum>k = 1..n. (a k))\<close>
  using \<open>n \<ge> 2\<close>
  apply auto
  by (smt add.commute add_leD2 le_add_diff_inverse numeral_1_eq_Suc_0 numeral_2_eq_2
      numeral_One plus_1_eq_Suc sum.nat_ivl_Suc')

lemma harmonic_numbers_2norm:
  fixes n::nat and r::rat
  assumes "n \<ge> 1"
  shows "pnorm 2 (Harm n) = 2^(nat(\<lfloor>log 2 n\<rfloor>))"
proof(cases \<open>n = 1\<close>)
  case True
  have \<open>prime (2::nat)\<close>
    by simp
  hence \<open>Harm 1 = 1\<close>
    by (simp add: One_rat_def)
  hence \<open>pnorm 2 (Harm 1) = pnorm 2 1\<close>
    by simp
  also have \<open>\<dots> = 1\<close>
    by simp
  also have \<open>\<dots> = 2^(nat(\<lfloor>log 2 1\<rfloor>))\<close>
  proof-
    have \<open>\<lfloor>log 2 1\<rfloor> = 0\<close>
      by simp
    thus ?thesis
      by auto
  qed
  finally show ?thesis
    using \<open>n = 1\<close>
    by auto
next
  case False
  hence \<open>n \<ge> 2\<close>
    using \<open>n \<ge> 1\<close>
    by auto
  define l where \<open>l = nat(\<lfloor>log 2 n\<rfloor>)\<close>
    (*
  define H where \<open>H = (\<Sum>k = 1..n. (inverse  (of_nat k)))\<close>
*)
  have \<open>prime (2::nat)\<close>
    by simp
  have \<open>l \<ge> 1\<close>
  proof-
    have \<open>log 2 n \<ge> 1\<close>
      using \<open>n \<ge> 2\<close>
      by auto
    hence \<open>\<lfloor>log 2 n\<rfloor> \<ge> 1\<close>
      by simp
    thus ?thesis
      using \<open>l = nat(\<lfloor>log 2 n\<rfloor>)\<close> \<open>1 \<le> \<lfloor>log 2 (real n)\<rfloor>\<close> \<open>l = nat \<lfloor>log 2 (real n)\<rfloor>\<close> nat_mono
      by presburger
  qed
  hence \<open>(2::nat)^l \<ge> 2\<close>
  proof -
    have "(2::nat) ^ 1 \<le> 2 ^ l"
      by (metis \<open>1 \<le> l\<close> one_le_numeral power_increasing)
    thus ?thesis
      by (metis semiring_normalization_rules(33))
  qed
  have \<open>pnorm 2 ((2^l) * Harm n) = 1\<close>
  proof-
    define pre_H where \<open>pre_H = (\<Sum>k = 1..(2^l-1). inverse (rat_of_nat k))\<close>
    define post_H where \<open>post_H = (\<Sum>k = (2^l+1)..n. inverse (rat_of_nat k))\<close>
    have \<open>Harm n = pre_H + (inverse  (of_nat (2^l))) + post_H\<close>
    proof-
      have \<open>pre_H + (inverse  (of_nat (2^l))) = (\<Sum>k = 1..(2^l-1). inverse (rat_of_nat k))
                  + (inverse  (of_nat (2^l)))\<close>
        unfolding pre_H_def
        by auto
      also have \<open>\<dots> = (\<Sum>k = 1..2^l. inverse (rat_of_nat k))\<close>
        by (metis  \<open>2 \<le> 2 ^ l\<close>  sum_last)
      finally have \<open>pre_H + inverse (rat_of_nat (2^l)) = (\<Sum>k = 1..2 ^ l. inverse (rat_of_nat k))\<close>
        by auto
      moreover have \<open>(\<Sum>k = 1..2 ^ l. inverse (rat_of_nat k)) + post_H = Harm n\<close>
      proof-
        have \<open>(\<Sum>k = 1..2 ^ l. inverse (rat_of_nat k)) + post_H
              = (\<Sum>k = 1..2 ^ l. inverse (rat_of_nat k)) +
                (\<Sum>k = 2 ^ l + 1..n. inverse (rat_of_nat k))\<close>
          unfolding post_H_def
          by blast
        also have \<open>\<dots>  = (\<Sum>k = 1..n. inverse (rat_of_nat k))\<close>
        proof-
          have \<open>2 ^ l \<le> n\<close>
          proof-
            have \<open>2 ^ l =  2 ^ nat \<lfloor>log 2 (real n)\<rfloor>\<close>
              unfolding l_def
              by simp
            also have \<open>\<dots> =  2 powi (nat \<lfloor>log 2 (real n)\<rfloor>)\<close>
              by (metis intpow_int)
            also have \<open>\<dots> \<le>  2 powr (log 2 (real n))\<close>
            proof-
              have \<open>\<lfloor>log 2 (real n)\<rfloor> \<le> log 2 (real n)\<close>
                by simp
              moreover have \<open>(2::real) > 1\<close>
                by simp
              ultimately show ?thesis
                using Transcendental.powr_le_cancel_iff[where x = 2 and a = "\<lfloor>log 2 (real n)\<rfloor>"
                    and b = "log 2 (real n)"] assms unfolding intpow_def
                by (simp add: powr_real_of_int)
            qed
            also have \<open>\<dots> = n\<close>
            proof-
              have \<open>(2::real) > 1\<close>
                by simp
              moreover have \<open>n > 0\<close>
                using \<open>n \<ge> 2\<close>
                by auto
              ultimately show ?thesis
                by simp
            qed
            finally show ?thesis
              by simp
          qed
          thus ?thesis
            by (metis le_add2 le_add_diff_inverse sum.ub_add_nat)
        qed
        finally have \<open>(\<Sum>k = 1..2 ^ l. inverse (rat_of_nat k)) + post_H =
            (\<Sum>k = 1..n.  inverse (rat_of_nat k))\<close>
          by auto
        thus ?thesis
          unfolding pre_H_def
          using Harm_explicit by auto
      qed
      ultimately show ?thesis
        by linarith
    qed
    moreover have \<open>pnorm 2 ((2^l) * (inverse  (of_nat (2^l)))) = 1\<close>
    proof-
      have \<open>(2::nat)^l \<noteq> 0\<close>
        by auto
      hence \<open>((2::nat)^l) * (inverse  (of_nat ((2::nat)^l))) = 1\<close>
      proof -
        have "int (2 ^ l) \<noteq> 0"
          using \<open>2 ^ l \<noteq> 0\<close> by linarith
        hence "1 = Fract (int (2 ^ l) * 1) (int (2 ^ l) * 1)"
          by (metis (no_types) One_rat_def mult_rat_cancel)
        thus ?thesis
          by simp
      qed
      hence \<open>pnorm 2 (((2::rat)^l) * (inverse  (of_nat ((2::nat)^l)))) = pnorm 2 1\<close>
        by simp
      also have \<open>\<dots> = 1\<close>
        by simp
      finally show ?thesis
        by blast
    qed
    moreover have \<open>pnorm 2 ((2^l) * pre_H) < 1\<close>
    proof-
      have \<open>(2^l) * pre_H = (\<Sum>k = 1..2 ^ l - 1. (2^l) * inverse (rat_of_nat k) )\<close>
        unfolding pre_H_def
        using Groups_Big.semiring_0_class.sum_distrib_left[where r = \<open>2^l\<close>
            and f = \<open>(\<lambda> k. inverse (rat_of_nat k))\<close> and A = \<open>{1..(2^l - 1)}\<close>]
        by auto
      hence \<open>pnorm 2 (2 ^ l * pre_H) =
              pnorm 2 (\<Sum>k = 1..2 ^ l - 1. (2 ^ l) * inverse (rat_of_nat k))\<close>
        by simp
      also have \<open>\<dots> \<le>
              Max ((\<lambda> k. pnorm 2 ((2 ^ l) * inverse (rat_of_nat k)))`{1..2^l-1})\<close>
      proof-
        have \<open>pnorm 2 (\<Sum>k = 1..2 ^ l - 1.  (2 ^ l) * inverse (rat_of_nat k))
           = pnorm 2 (sum (\<lambda> k.  (2 ^ l) * inverse (rat_of_nat k)) {1..(2::nat)^l-1})\<close>
          by blast
        also have \<open>\<dots> \<le> Max ((\<lambda> k. pnorm 2 ((2 ^ l) * inverse (rat_of_nat k) ))`{1..2^l-1})\<close>
          using \<open>prime 2\<close>  pnorm_sum_le[where p = 2 and A = \<open>{1..2^l-1}\<close>
              and x = \<open>(\<lambda> k. (2 ^ l) * inverse (rat_of_nat k))\<close>]
          by (metis Nat.le_diff_conv2 \<open>2 \<le> 2 ^ l\<close> add_leD1 atLeastatMost_empty_iff2
              finite_atLeastAtMost nat_1_add_1)
        finally show ?thesis
          using \<open>pnorm 2 (\<Sum>k = 1..2 ^ l - 1. 2 ^ l * inverse (rat_of_nat k))
            \<le> (MAX k\<in>{1..2 ^ l - 1}. pnorm 2 (2 ^ l * inverse (rat_of_nat k)))\<close> by blast
      qed
      also have \<open>\<dots> < 1\<close>
      proof-
        have \<open>finite ((\<lambda> k. pnorm 2 (2 ^ l) * inverse (rat_of_nat k))`{1..2^l-1})\<close>
          by blast
        moreover have \<open>((\<lambda> k. pnorm 2 ((2 ^ l) * inverse (rat_of_nat k)))`{1..2^l-1}) \<noteq> {}\<close>
        proof-
          have \<open>(1::nat) \<le> (2::nat)^l-1\<close>
            using \<open>(2::nat)^l \<ge> 2\<close>
            by auto
          hence \<open>{(1::nat)..(2::nat)^l-1} \<noteq> {}\<close>
            using Set_Interval.order_class.atLeastatMost_empty_iff2[where a = "1::nat"
                and b = "(2::nat)^l - 1"]
            by auto
          thus ?thesis
            by blast
        qed
        moreover have \<open>x \<in> ((\<lambda> k. pnorm 2 ((2 ^ l) * inverse (rat_of_nat k)))`{1..2^l-1}) \<Longrightarrow> x < 1\<close>
          for x
        proof-
          assume \<open>x \<in> ((\<lambda> k. pnorm 2 ((2 ^ l) * inverse (rat_of_nat k)))`{1..2^l-1})\<close>
          then obtain k where \<open>x = pnorm 2 ((2 ^ l) * inverse (rat_of_nat k))\<close> and \<open>k \<in> {1..2^l-1}\<close>
            by blast
          have \<open>pnorm 2 ((2 ^ l) * inverse (rat_of_nat k)) < 1\<close>
          proof-
            have \<open>pnorm 2 ((2::rat)^l) = 1/(2::nat)^l\<close>
              using  \<open>prime (2::nat)\<close> pnorm_primepow[where p = "(2::nat)"]
              by auto
            moreover have \<open>pnorm 2 (inverse (rat_of_nat k)) < (2::nat)^l\<close>
            proof-
              have \<open>2 powi (- pval 2 (inverse (rat_of_nat k))) < (2::nat)^l\<close>
              proof-
                have \<open>pval 2 (Fract k 1) < l\<close>
                proof-
                  have \<open>pval 2 (Fract k 1) = multiplicity (2::int) k\<close>
                    by (smt Fract_of_nat_eq Suc_1 multiplicity_int_int of_nat_1 of_nat_Suc
                        pval_of_nat)
                  also have \<open>\<dots> < l\<close>
                  proof(rule classical)
                    assume \<open>\<not>(multiplicity 2 (int k) < int l)\<close>
                    hence \<open>multiplicity 2 (int k) \<ge> int l\<close>
                      by simp
                    hence \<open>((2::nat)^l) dvd k\<close>
                      by (metis (full_types) int_dvd_int_iff multiplicity_dvd' of_nat_numeral
                          of_nat_power zle_int)
                    hence \<open>(2::nat)^l \<le> k\<close>
                      using \<open>k \<in> {1..2 ^ l - 1}\<close> dvd_nat_bounds
                      by auto
                    moreover have \<open>k < (2::nat)^l\<close>
                      using  \<open>k\<in>{1..(2::nat)^l - 1}\<close>
                      by auto
                    ultimately show ?thesis
                      by linarith
                  qed
                  finally show ?thesis
                    by blast
                qed
                hence \<open>- pval 2 (inverse (rat_of_int k)) < l\<close>
                  using \<open>prime 2\<close> pval_inverse[where p = "2" and x = \<open>inverse (rat_of_int k)\<close>]
                    Fract_of_int_quotient
                  by auto
                hence \<open>2 powr (- pval 2 (inverse (rat_of_int k))) < 2 powr l\<close>
                  by auto
                also have \<open>\<dots> = (2::nat)^l\<close>
                proof -
                  have f1: "\<not> 2 \<le> (1::real)"
                    by auto
                  have f2: "\<forall>x1. ((1::real) < x1) = (\<not> x1 \<le> 1)"
                    by force
                  have "real (2 ^ l) = 2 ^ l"
                    by simp
                  hence "real l = log 2 (real (2 ^ l))"
                    using f2 f1 by (meson log_of_power_eq)
                  thus ?thesis
                    by simp
                qed
                finally show ?thesis
                  unfolding intpow_def
                  using of_int_of_nat_eq power_inverse powr_real_of_int
                    \<open>- pval 2 (inverse (rat_of_int (int k))) < int l\<close> by auto
              qed
              moreover have \<open>pnorm 2 (inverse (rat_of_nat k)) = 2 powi (- pval 2 (inverse (rat_of_nat k)))\<close>
              proof-
                have \<open>k \<noteq> 0\<close>
                  using \<open>k\<in>{1..2^l - 1}\<close>
                  by simp
                hence \<open>inverse (rat_of_int k) \<noteq> 0\<close>
                  by auto
                thus ?thesis
                  using \<open>prime 2\<close> \<open>k \<noteq> 0\<close>
                  unfolding pnorm_def intpow_def
                  apply auto
                  by (simp add: powr_realpow)
              qed
              ultimately show ?thesis
                by auto
            qed
            moreover have \<open>pnorm 2 ((2::rat)^l) > 0\<close>
            proof-
              have \<open>(2::rat)^l \<noteq> 0\<close>
                by simp
              moreover have \<open>pnorm 2 ((2::rat)^l) \<ge> 0\<close>
                by (simp add: pnorm_nonneg)
              ultimately show ?thesis
                by (simp add: less_eq_real_def)
            qed
            moreover have \<open>pnorm 2 (inverse (rat_of_nat k)) > 0\<close>
            proof-
              have \<open>inverse (rat_of_nat k) \<noteq> 0\<close>
                using \<open>k \<in> {1..2^l-1}\<close>
                by simp
              moreover have \<open>pnorm 2 (inverse (rat_of_nat k)) \<ge> 0\<close>
                using \<open>prime (2::nat)\<close>
                by (simp add: pnorm_nonneg)
              ultimately show ?thesis
                using  \<open>prime (2::nat)\<close>
                by (simp add: pnorm_pos)
            qed
            ultimately have \<open>(pnorm 2 ((2::rat)^l))*(pnorm 2 (inverse (rat_of_nat k)))
                  < (1/(2::nat)^l)*((2::nat)^l)\<close>
              by simp
            also have \<open>\<dots> = 1\<close>
            proof-
              have \<open>(2::nat)^l \<noteq> 0\<close>
                by simp
              thus ?thesis
                by simp
            qed
            finally have \<open>(pnorm 2 ((2::rat)^l))*(pnorm 2 (inverse (rat_of_nat k))) < 1\<close>
              by blast
            moreover have \<open>(pnorm 2 ((2::rat)^l))*(pnorm 2 (inverse (rat_of_nat k)))
                  = pnorm 2 (2 ^ l * inverse (rat_of_nat k))\<close>
              using \<open>prime 2\<close>
              by simp
            ultimately show ?thesis
              by auto
          qed
          thus ?thesis
            using \<open>x = pnorm 2 (2 ^ l * inverse (rat_of_nat k))\<close> by blast

        qed
        ultimately show ?thesis
          using Lattices_Big.linorder_class.Max_less_iff
            [where A = "((\<lambda> k. pnorm 2 (Fract (2 ^ l) (int k)))`{1..2^l-1})"]
          by auto
      qed
      finally show \<open>pnorm 2 (2 ^ l * pre_H) < 1\<close>
        by blast
    qed
    ultimately have \<open>pnorm 2 ((2^l) * (inverse  (of_nat (2^l))) + (2^l) * pre_H) = 1\<close>
      using pnorm_unit_ball[where p = 2 and x = "(2^l) *  (inverse  (of_nat (2^l)))" and y = "(2^l) * pre_H"]
      by simp
    moreover have \<open>pnorm 2 ((2^l) * post_H) < 1\<close>
    proof(cases \<open>2^l + 1 \<le> n\<close>)
      case True
      have \<open>pnorm 2 ((2^l) * post_H) = pnorm 2 (\<Sum>k = 2 ^ l + 1..n.  (2 ^ l)*(inverse (rat_of_int k)))\<close>
      proof-
        have \<open>(2^l) * post_H = (\<Sum>k = 2 ^ l+1..n. (2 ^ l)*(inverse (rat_of_int k)))\<close>
          unfolding post_H_def
          using Groups_Big.semiring_0_class.sum_distrib_left[where r = \<open>2^l\<close>
              and f = \<open>(\<lambda> k. inverse (rat_of_int k))\<close> and A = \<open>{2 ^ l+1..n}\<close>]
          by auto
        thus ?thesis
          by simp
      qed
      also have \<open>\<dots>
           = pnorm 2 (sum (\<lambda> k. (2 ^ l)*(inverse (rat_of_int k))) {2 ^ l + 1..n})\<close>
        by blast
      also have \<open>\<dots>
           \<le> Max ((\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n})\<close>
      proof-
        have \<open>finite {2 ^ l + 1..n}\<close>
          by simp
        moreover have \<open>{2 ^ l + 1..n} \<noteq> {}\<close>
          using True
          by auto
        ultimately show ?thesis
          using \<open>prime 2\<close>  pnorm_sum_le[where p = 2 and A = \<open>{2 ^ l + 1..n}\<close>
              and x = \<open>(\<lambda> k. (2 ^ l)*(inverse (rat_of_int k)))\<close>]
          by auto
      qed
      finally have \<open>pnorm 2 ((2^l) * post_H) \<le>
          Max ((\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n})\<close>
        using \<open>pnorm 2 (2 ^ l * post_H)
            = pnorm 2 (\<Sum>k = 2 ^ l + 1..n. 2 ^ l * inverse (rat_of_int (int k)))\<close>
          \<open>pnorm 2 (\<Sum>k = 2 ^ l + 1..n. 2 ^ l * inverse (rat_of_int (int k)))
          \<le> (MAX k\<in>{2 ^ l + 1..n}. pnorm 2 (2 ^ l * inverse (rat_of_int (int k))))\<close>
        by linarith
      moreover have \<open>((\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n}) \<noteq> {}\<close>
        using True
        by auto
      moreover have \<open>finite ((\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n})\<close>
        by blast
      moreover have \<open>x \<in> (\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n} \<Longrightarrow> x < 1\<close>
        for x
      proof-
        assume \<open>x \<in> (\<lambda> k. pnorm 2 ((2 ^ l)*(inverse (rat_of_int k)))) ` {2 ^ l + 1..n}\<close>
        then obtain t where \<open>t \<in> {2 ^ l + 1..n}\<close> and \<open>x = pnorm 2 ((2 ^ l)*(inverse (rat_of_nat t)))\<close>
          by auto
        have  \<open>x = (pnorm 2 (2 ^ l)) * (pnorm 2 (inverse (rat_of_nat t)))\<close>
          using \<open>prime 2\<close> \<open>x = pnorm 2 ((2 ^ l)*(inverse  (rat_of_nat t)))\<close> pnorm_mult by blast
        moreover have \<open>pnorm 2 (2 ^ l) = 1/(2^l)\<close>
          using \<open>prime 2\<close> pval_primepow[where p = "2::nat"]
          by (metis of_int_numeral of_nat_numeral pnorm_primepow)
        moreover have \<open>pnorm 2 (inverse  (rat_of_nat t)) < 2^l\<close>
        proof(rule classical)
          assume \<open>\<not> (pnorm 2 (inverse  (rat_of_nat t)) < 2^l)\<close>
          hence \<open>pnorm 2 (inverse  (rat_of_nat t)) \<ge> 2^l\<close>
            by auto
          moreover have \<open>2 powi l = 2^l\<close>
            by auto
          ultimately have \<open>pnorm 2 (inverse  (rat_of_nat t)) \<ge> 2 powi l\<close>
            by auto
          moreover have \<open>pnorm 2 (inverse  (rat_of_nat t))
                          = 2 powi (-pval 2 (inverse  (rat_of_nat t)))\<close>
          proof-
            have \<open>t \<noteq> 0\<close>
              using \<open>t \<in> {2^l + 1 .. n}\<close>
              by simp
            hence \<open>inverse (rat_of_nat t) \<noteq> 0\<close>
            proof -
              have "\<not> int t \<le> 0"
                by (metis \<open>t \<noteq> 0\<close> of_nat_le_0_iff)
              hence "\<not> inverse  (int t) \<le> 0"
                by (simp add: Fract_le_zero_iff)
              thus ?thesis
                by auto
            qed
            thus ?thesis
              unfolding intpow_def pnorm_def
              apply auto
              by (simp add: powr_realpow)
          qed
          ultimately have \<open>-pval 2 (inverse  (rat_of_nat t)) \<ge> l\<close>
            by simp
          hence \<open>-(multiplicity 2 (fst (quotient_of (inverse  (rat_of_nat t)))))
               + (multiplicity 2 (snd (quotient_of (inverse  (rat_of_nat t)))))
                     \<ge> l\<close>
            unfolding pval_def
            by auto
          have \<open>quotient_of (inverse (rat_of_nat t)) = (1, t)\<close>
          proof-
            have \<open>inverse (rat_of_nat t) = Fract 1 t\<close>
              by (metis Fract_of_nat_eq inverse_rat)
            moreover have \<open>t > 0\<close>
              using \<open>t \<in> {2^l + 1 .. n}\<close>
              by simp
            moreover have \<open>coprime 1 t\<close>
              by simp
            ultimately show ?thesis
              by (simp add: quotient_of_Fract)
          qed
          hence \<open>fst (quotient_of (inverse  (rat_of_nat t))) = 1\<close>
            by simp
          moreover have \<open>snd (quotient_of (inverse  (rat_of_nat t))) = t\<close>
          proof -
            have "Rat.normalize (1, int t) = quotient_of (inverse (rat_of_nat t))"
              by (metis (full_types) Fract_of_int_eq inverse_rat of_int_of_nat_eq quotient_of_Fract)
            hence "Rat.normalize (1, int t) = (1, snd (quotient_of (inverse (rat_of_nat t))))"
              by (metis calculation prod.exhaust_sel)
            thus ?thesis
              by (metis (full_types) Fract_of_int_eq inverse_rat normalize_eq of_int_eq_iff)
          qed
          ultimately have \<open>- int(multiplicity (2::int) 1) + int(multiplicity (2::int) t) \<ge> l\<close>
            using \<open>-(multiplicity 2 (fst (quotient_of (inverse  (rat_of_nat t)))))
               + (multiplicity 2 (snd (quotient_of (inverse  (rat_of_nat t)))))
                     \<ge> l\<close>
            by auto
          moreover have \<open>multiplicity (2::int) 1 = 0\<close>
            by simp
          ultimately have \<open>multiplicity (2::int) t \<ge> l\<close>
            by auto
          hence \<open>2^l dvd t\<close>
            by (metis int_dvd_int_iff multiplicity_dvd' of_nat_numeral of_nat_power)
          hence \<open>\<exists> k::nat. 2^l * k = t\<close>
            by auto
          then obtain k::nat where \<open>2^l * k = t\<close>
            by blast
          have \<open>k \<ge> 2\<close>
          proof(rule classical)
            assume \<open>\<not>(k \<ge> 2)\<close>
            hence \<open>k < 2\<close>
              by simp
            moreover have \<open>k \<noteq> 0\<close>
            proof(rule classical)
              assume \<open>\<not>(k \<noteq> 0)\<close>
              hence \<open>k = 0\<close>
                by simp
              hence \<open>t = 0\<close>
                using \<open>2^l * k = t\<close>
                by auto
              thus ?thesis
                using \<open>t \<in> {2^l + 1 .. n}\<close>
                by auto
            qed
            moreover have \<open>k \<noteq> 1\<close>
            proof(rule classical)
              assume \<open>\<not>(k \<noteq> 1)\<close>
              hence \<open>k = 1\<close>
                by simp
              hence \<open>t = 2^l\<close>
                using \<open>2^l * k = t\<close>
                by auto
              thus ?thesis
                using \<open>t \<in> {2^l + 1 .. n}\<close>
                by auto
            qed
            ultimately show ?thesis
              by auto
          qed
          hence \<open>2^(Suc l) \<le> t\<close>
            using \<open>2 ^ l * k = t\<close>
            by auto
          hence \<open>2^(Suc l) \<le> n\<close>
            using \<open>t \<in> {2^l + 1 .. n}\<close>
            by auto
          moreover have \<open>n < 2^(Suc l)\<close>
          proof -
            have f1: "\<forall>n na. (n \<le> na) = (int n + - 1 * int na \<le> 0)"
              by auto
            have f2: "int (Suc (nat \<lfloor>log 2 (real n)\<rfloor>)) + - 1 * int (Suc l) \<le> 0"
              by (simp add: l_def)
            have f3: "(- 1 * log 2 (real n) + real (Suc l) \<le> 0) = (0 \<le> log 2 (real n) + - 1 * real (Suc l))"
              by fastforce
            have f4: "real (Suc l) + - 1 * log 2 (real n) = - 1 * log 2 (real n) + real (Suc l)"
              by auto
            have f5: "\<forall>n na. \<not> 2 ^ n \<le> na \<or> real n + - 1 * log 2 (real na) \<le> 0"
              by (simp add: le_log2_of_power)
            have f6: "\<forall>x0 x1. (- 1 * int x0 + int (2 ^ x1) \<le> 0) = (0 \<le> int x0 + - 1 * int (2 ^ x1))"
              by auto
            have f7: "\<forall>x0 x1. int (2 ^ x1) + - 1 * int x0 = - 1 * int x0 + int (2 ^ x1)"
              by auto
            have "\<not> 0 \<le> log 2 (real n) + - 1 * real (Suc l)"
              using f2 by linarith
            then have "\<not> 0 \<le> int n + - 1 * int (2 ^ Suc l)"
              using f7 f6 f5 f4 f3 f1 by (metis (no_types))
            then show ?thesis
              by linarith
          qed
          ultimately show ?thesis
            by auto
        qed
        moreover have \<open>pnorm 2 (2 ^ l) \<ge> 0\<close>
          by (simp add: pnorm_nonneg)
        moreover have \<open>pnorm 2 (inverse  (rat_of_nat t)) \<ge> 0\<close>
          by (simp add: pnorm_nonneg)
        ultimately show ?thesis
          by simp
      qed
      ultimately show ?thesis
        by (smt Max_in)
    next
      case False
      hence \<open>2 ^ l + 1 > n\<close>
        by simp
      hence \<open>{2 ^ l + 1..n} = {}\<close>
        by simp
      hence \<open>post_H = 0\<close>
        unfolding post_H_def
        by simp
      hence \<open>(2^l) * post_H = 0\<close>
        by (simp add: \<open>post_H = 0\<close>)
      thus ?thesis
        unfolding pnorm_def
        by auto
    qed
    ultimately have \<open>pnorm 2 (((2^l) *  (inverse  (of_nat (2^l)))
                                  + (2^l) * pre_H) + ((2^l) * post_H)) = 1\<close>
      using pnorm_unit_ball[where p = 2 and x = "(2^l) *  (inverse  (of_nat (2^l))) + (2^l) * pre_H"
          and y = "(2^l) * post_H"]
      by simp
    moreover have \<open>2 ^ l * inverse (rat_of_nat (2 ^ l)) + 2 ^ l * pre_H + 2 ^ l * post_H
          = 2^l * Harm n\<close>
      using \<open>Harm n = pre_H + (inverse  (of_nat (2^l))) + post_H\<close>
      by (simp add: semiring_normalization_rules(34))
    ultimately show ?thesis
      by auto
  qed
  hence \<open>(pnorm 2 (2^l)) * (pnorm 2 (Harm n)) = 1\<close>
    using Pnorm.pnorm_mult \<open>prime 2\<close>
    by auto
  hence \<open>(1/2^l) * (pnorm 2 (Harm n)) = 1\<close>
  proof-
    have \<open>prime (2::nat)\<close>
      by simp
    hence \<open>pnorm 2 (2^l) = 1/2^l\<close>
      using pnorm_primepow[where p = 2 and l = "l"]
      by simp
    thus ?thesis
      using \<open>pnorm 2 (2 ^ l) * pnorm 2 (Harm n) = 1\<close>
      by auto
  qed
  hence \<open>pnorm 2 (Harm n) = 2^l\<close>
    by simp
  thus ?thesis
    by (simp add: l_def)
qed

lemma Harm_mono: "m \<noteq> 0 \<Longrightarrow> 2*m \<le> n \<Longrightarrow> pnorm 2 (Harm m) < pnorm 2 (Harm n)"
proof-
  assume \<open>m \<noteq> 0\<close> and \<open>2*m \<le> n\<close>
  have \<open>m \<ge> 1\<close>
    using \<open>m \<noteq> 0\<close> by linarith
  have \<open>pnorm 2 (Harm m) =  2 ^ nat \<lfloor>log 2 (real m)\<rfloor>\<close>
    using harmonic_numbers_2norm[where n = "m"] \<open>m \<noteq> 0\<close>
    by auto
  moreover have \<open>pnorm 2 (Harm n) =  2 ^ nat \<lfloor>log 2 (real n)\<rfloor>\<close>
    using harmonic_numbers_2norm[where n = "n"] \<open>2 * m \<le> n\<close> \<open>m \<noteq> 0\<close> by linarith
  moreover have \<open>(2::nat) ^ nat \<lfloor>log 2 (real m)\<rfloor> < (2::nat) ^ nat \<lfloor>log 2 (real n)\<rfloor>\<close>
  proof-
    have \<open>log 2 (real m) + 1 = log 2 (real m) + log 2 (2::real)\<close>
    proof-
      have \<open>log 2 (real 2) = 1\<close>
        by simp
      thus ?thesis
        by simp
    qed
    also have \<open>\<dots> = log 2 ((real m) * (2::real)) \<close>
    proof-
      have \<open>(2::real) > 0\<close>
        by simp
      moreover have \<open>(2::real) \<noteq> 1\<close>
        by simp
      ultimately show ?thesis
        using \<open>m \<ge> 1\<close> log_mult[where a = 2 and x = "real m" and y = "2::real"]
        by simp
    qed
    also have \<open>\<dots> = log 2 (2*real m) \<close>
    proof-
      have \<open>(real m)*(2::real) = 2*m\<close>
        by auto
      thus ?thesis
        by (simp add: \<open>real m * 2 = real (2 * m)\<close>)
    qed
    also have \<open>\<dots> \<le> log 2 (real n)\<close>
      using \<open>2*m \<le> n\<close> \<open>m \<noteq> 0\<close> by auto
    finally have \<open>log 2 (real m) + 1 \<le> log 2 (real n)\<close>
      by blast
    hence \<open>\<lfloor>log 2 (real m)\<rfloor> < \<lfloor>log 2 (real n)\<rfloor>\<close>
      by linarith
    moreover have \<open>\<lfloor>log 2 (real m)\<rfloor> \<ge> 0\<close>
    proof-
      have \<open>log 2 (real m) \<ge> 0\<close>
        using \<open>m \<ge> 1\<close> by auto
      thus ?thesis by auto
    qed
    ultimately have \<open>nat \<lfloor>log 2 (real m)\<rfloor> < nat \<lfloor>log 2 (real n)\<rfloor>\<close>
      using nat_less_eq_zless by blast
    moreover have \<open>(2::nat) > 1\<close>
      by auto
    ultimately show ?thesis
      using power_strict_increasing[where a = "2::nat" and n = "nat \<lfloor>log 2 (real m)\<rfloor>"
          and N = "nat \<lfloor>log 2 (real n)\<rfloor>"] by blast
  qed
  ultimately show ?thesis
    by auto
qed

subsection \<open>Main results\<close>

text\<open>The following result is due to L. Taeisinger ~\cite{theisinger1915bemerkung}.\<close>
theorem Taeisinger:
  fixes n :: nat
  assumes \<open>n \<ge> 2\<close>
  shows \<open>Harm n \<notin> \<int>\<close>
proof-
  have  \<open>prime (2::nat)\<close>
    by simp
  moreover have \<open>pnorm 2 (Harm n) > 1\<close>
    using harmonic_numbers_2norm[where n = "n"] \<open>n \<ge> 2\<close>
    by auto
  ultimately show ?thesis
    using integers_pnorm[where x = "Harm n"] by smt
qed

text\<open>The following result is due to J. K{\"u}rsch{\'a}k  ~\cite{kurschak1918harmonic}.\<close>
theorem Kurschak:
  fixes n m :: nat
  assumes \<open>m + 2 \<le> n\<close>
  shows \<open>Harm n - Harm m \<notin> \<int>\<close>
proof(cases \<open>2*m \<le> n\<close>)
  case True show ?thesis
  proof(cases \<open>m = 0\<close>)
    case True thus ?thesis using Taeisinger assms by auto
  next
    case False
    have \<open>n \<ge> 2\<close>
      using \<open>m+2 \<le> n\<close> by auto
    have \<open>prime (2::nat)\<close>
      by auto
    have \<open>Harm n = (Harm n - Harm m) + (Harm m)\<close>
      by simp
    hence \<open>pnorm 2 (Harm n) \<le> max (pnorm 2 (Harm n - Harm m)) (pnorm 2 (Harm m))\<close>
      using pnorm_add_le[where p = "2::nat" and x = "Harm n - Harm m" and y = "Harm m"] by simp
    moreover have \<open>pnorm 2 (Harm m) < pnorm 2 (Harm n)\<close>
      by (simp add: False Harm_mono True)
    ultimately have \<open>pnorm 2 (Harm n) \<le> pnorm 2 (Harm n - Harm m)\<close>
      by linarith
    moreover have \<open>1 < pnorm 2 (Harm n)\<close>
      using harmonic_numbers_2norm[where n = "n"] \<open>n \<ge> 2\<close> by auto
    ultimately have \<open>1 < pnorm 2 (Harm n - Harm m)\<close>
      by auto
    thus ?thesis
      using integers_pnorm[where x = "Harm n - Harm m"] \<open>prime 2\<close> by smt
  qed
next
  case False
  have \<open>n \<ge> m\<close>
    using add_leE assms by blast
  have \<open>Harm n - Harm m < 1\<close>
    using False Harm_diff_less_1 assms by auto
  moreover have \<open>0 < Harm n - Harm m\<close>
    using Harm_incre \<open>m+2 \<le> n\<close> by simp
  have f1: "sgn (Harm n - Harm m) = 1"
    by (metis \<open>0 < Harm n - Harm m\<close> sgn_pos)
  have "0 \<le> Harm n - Harm m"
    by (metis \<open>0 < Harm n - Harm m\<close> less_eq_rat_def)
  thus ?thesis using f1 \<open>Harm n - Harm m < 1\<close> frac_eq_0_iff sgn_if zero_neq_one frac_eq by metis
qed

end


(*
  Title:    Random_Permutations.thy
  Author:   Manuel Eberl, TU München

  Random permutations and folding over them.
  This provides the basic theory for the concept of doing something
  in a random order, e.g. inserting elements from a fixed set into a
  data structure in random order.
*)

section \<open>Random Permutations\<close>

theory Random_Permutations
imports "~~/src/HOL/Probability/Probability" Set_Permutations
begin

(* TODO Move *)
declare bind_pmf_cong [fundef_cong]

adhoc_overloading Monad_Syntax.bind bind_pmf

lemma pmf_bind_pmf_of_set:
  assumes "A \<noteq> {}" "finite A"
  shows   "pmf (bind_pmf (pmf_of_set A) f) x =
             (\<Sum>xa\<in>A. pmf (f xa) x) / real_of_nat (card A)" (is "?lhs = ?rhs")
proof -
  from assms have "ereal ?lhs = ereal ?rhs"
    by (subst ereal_pmf_bind) (simp_all add: nn_integral_pmf_of_set max_def pmf_nonneg)
  thus ?thesis by simp
qed

text \<open>
  The indicator function of the union of a disjoint family of sets is the
  sum over all the individual indicators.
\<close>
lemma indicator_UN_disjoint:
  assumes "finite A" "disjoint_family_on f A"
  shows   "indicator (UNION A f) x = (\<Sum>y\<in>A. indicator (f y) x)"
  using assms by (induction A rule: finite_induct)
                 (auto simp: disjoint_family_on_def indicator_def split: if_splits)

text \<open>
  The union of an infinite disjoint family of non-empty sets is infinite.
\<close>
lemma infinite_disjoint_family_imp_infinite_UNION:
  assumes "\<not>finite A" "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> {}" "disjoint_family_on f A"
  shows   "\<not>finite (UNION A f)"
proof -
  def g \<equiv> "\<lambda>x. SOME y. y \<in> f x"
  have g: "g x \<in> f x" if "x \<in> A" for x
    unfolding g_def by (rule someI_ex, insert assms(2) that) blast
  have inj_on_g: "inj_on g A"
  proof (rule inj_onI, rule ccontr)
    fix x y assume A: "x \<in> A" "y \<in> A" "g x = g y" "x \<noteq> y"
    with g[of x] g[of y] have "g x \<in> f x" "g x \<in> f y" by auto
    with A `x \<noteq> y` assms show False
      by (auto simp: disjoint_family_on_def inj_on_def)
  qed
  from g have "g ` A \<subseteq> UNION A f" by blast
  moreover from inj_on_g \<open>\<not>finite A\<close> have "\<not>finite (g ` A)"
    using finite_imageD by blast
  ultimately show ?thesis using finite_subset by blast
qed

text \<open>
  Choosing an element uniformly at random from the union of a disjoint family
  of finite non-empty sets with the same size is the same as first choosing a set
  from the family uniformly at random and then choosing an element from the chosen set
  uniformly at random.
\<close>
lemma pmf_of_set_UN:
  assumes "finite (UNION A f)" "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> {}"
          "\<And>x. x \<in> A \<Longrightarrow> card (f x) = n" "disjoint_family_on f A"
  shows   "pmf_of_set (UNION A f) = do {x \<leftarrow> pmf_of_set A; pmf_of_set (f x)}"
            (is "?lhs = ?rhs")
proof (intro pmf_eqI)
  fix x
  from assms have [simp]: "finite A"
    using infinite_disjoint_family_imp_infinite_UNION[of A f] by blast
  from assms have "ereal (pmf (pmf_of_set (UNION A f)) x) =
    ereal (indicator (\<Union>x\<in>A. f x) x / real (card (\<Union>x\<in>A. f x)))"
    by (subst pmf_of_set) auto
  also from assms have "card (\<Union>x\<in>A. f x) = card A * n"
    by (subst card_UN_disjoint) (auto simp: disjoint_family_on_def)
  also from assms
    have "indicator (\<Union>x\<in>A. f x) x / real \<dots> =
              indicator (\<Union>x\<in>A. f x) x / (n * real (card A))"
      by (simp add: setsum_divide_distrib [symmetric] mult_ac)
  also from assms have "indicator (\<Union>x\<in>A. f x) x = (\<Sum>y\<in>A. indicator (f y) x)"
    by (intro indicator_UN_disjoint) simp_all
  also from assms have "ereal ((\<Sum>y\<in>A. indicator (f y) x) / (real n * real (card A))) =
                          ereal (pmf ?rhs x)"
    by (subst pmf_bind_pmf_of_set) (simp_all add: setsum_divide_distrib)
  finally show "pmf ?lhs x = pmf ?rhs x" by simp
qed

(* END TODO *)

text \<open>
  Choosing a set permutation (i.e. a distinct list with the same elements as the set)
  uniformly at random is the same as first choosing the first element of the list
  and then choosing the rest of the list as a permutation of the remaining set.
\<close>
lemma random_permutation_of_set:
  assumes "finite A" "A \<noteq> {}"
  shows   "pmf_of_set (permutations_of_set A) =
             do {
               x \<leftarrow> pmf_of_set A;
               xs \<leftarrow> pmf_of_set (permutations_of_set (A - {x}));
               return_pmf (x#xs)
             }" (is "?lhs = ?rhs")
proof -
  from assms have "permutations_of_set A = (\<Union>x\<in>A. op # x ` permutations_of_set (A - {x}))"
    by (simp add: permutations_of_set_nonempty)
  also from assms have "pmf_of_set \<dots> = ?rhs"
    by (subst pmf_of_set_UN[where n = "fact (card A - 1)"])
       (auto simp: card_image disjoint_family_on_def map_pmf_def [symmetric] map_pmf_of_set_inj)
  finally show ?thesis .
qed

text \<open>
  A generic fold function that takes a function, an initial state, and a set
  and chooses a random order in which it then traverses the set in the same
  fashion as a left-fold over a list.
    We first give a recursive definition.
\<close>
function fold_random_permutation :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b pmf" where
  "fold_random_permutation f x {} = return_pmf x"
| "\<not>finite A \<Longrightarrow> fold_random_permutation f x A = return_pmf x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_random_permutation f x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))"
by (force, simp_all)
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b and y :: 'a
  assume "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  moreover from this have "card A > 0" by (simp add: card_gt_0_iff)
  ultimately show "((f, f y x, A - {y}), f, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We can now show that the above recursive definition is equivalent to
  choosing a random set permutation and folding over it (in any direction).
\<close>
lemma fold_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
using assms
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove
    have "fold_random_permutation f x A =
            pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))" by simp
  also from remove
    have "\<dots> = pmf_of_set A \<bind> (\<lambda>a. map_pmf (foldl (\<lambda>x y. f y x) x)
                 (map_pmf (op # a) (pmf_of_set (permutations_of_set (A - {a})))))"
      by (intro bind_pmf_cong) (simp_all add: pmf.map_comp o_def)
  also from remove have "\<dots> = map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
    by (simp_all add: random_permutation_of_set map_bind_pmf map_pmf_def [symmetric])
  finally show ?case .
qed (simp_all add: pmf_of_set_singleton)

lemma fold_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. foldr f xs x) (pmf_of_set (permutations_of_set A))"
proof -
  have "fold_random_permutation f x A =
          map_pmf (foldl (\<lambda>x y. f y x) x \<circ> rev) (pmf_of_set (permutations_of_set A))"
    using assms by (subst fold_random_permutation_foldl [OF assms])
                   (simp_all add: pmf.map_comp [symmetric] map_pmf_of_set_inj)
  also have "foldl (\<lambda>x y. f y x) x \<circ> rev = (\<lambda>xs. foldr f xs x)"
    by (intro ext) (simp add: foldl_conv_foldr)
  finally show ?thesis .
qed

lemma fold_random_permutation_fold:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. fold f xs x) (pmf_of_set (permutations_of_set A))"
  by (subst fold_random_permutation_foldl [OF assms], intro map_pmf_cong)
     (simp_all add: foldl_conv_fold)

text \<open>
  We now introduce a slightly generalised version of the above fold
  operation that does not simply return the result in the end, but applies
  a monadic bind to it.
    This may seem somewhat arbitrary, but it is a common use case, e.g.
  in the Social Decision Scheme of Random Serial Dictatorship, where
  voters narrow down a set of possible winners in a random order and
  the winner is chosen from the remaining set uniformly at random.
\<close>
function fold_bind_random_permutation
    :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c pmf) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'c pmf" where
  "fold_bind_random_permutation f g x {} = g x"
| "\<not>finite A \<Longrightarrow> fold_bind_random_permutation f g x A = g x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_bind_random_permutation f g x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a}))"
by (force, simp_all)
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b
    and y :: 'a and g :: "'b \<Rightarrow> 'c pmf"
  assume "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  moreover from this have "card A > 0" by (simp add: card_gt_0_iff)
  ultimately show "((f, g, f y x, A - {y}), f, g, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We now show that the recursive definition is equivalent to
  a random fold followed by a monadic bind.
\<close>
lemma fold_bind_random_permutation_altdef:
  "fold_bind_random_permutation f g x A = fold_random_permutation f x A \<bind> g"
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove have "pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a})) =
                      pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}) \<bind> g)"
    by (intro bind_pmf_cong) simp_all
  with remove show ?case by (simp add: bind_return_pmf bind_assoc_pmf)
qed (simp_all add: bind_return_pmf)

text \<open>
  We can now derive the following nice monadic representations of the
  combined fold-and-bind:
\<close>
lemma fold_bind_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldl (\<lambda>x y. f y x) x xs)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldl bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldr f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldr bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_fold:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (fold f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_fold bind_return_pmf map_pmf_def)

end


(* Title:      HOL/Analysis/Cross3.thy
   Author:     L C Paulson, University of Cambridge

Ported from HOL Light
*)

section\<open>Vector Cross Products in 3 Dimensions\<close>

theory "Cross3"
  imports Determinants Cartesian_Euclidean_Space
begin

context includes no_Set_Product_syntax
begin \<comment>\<open>locally disable syntax for set product, to avoid warnings\<close>

definition\<^marker>\<open>tag important\<close> cross3 :: "[real^3, real^3] \<Rightarrow> real^3"  (infixr "\<times>" 80)
  where "a \<times> b \<equiv>
    vector [a$2 * b$3 - a$3 * b$2,
            a$3 * b$1 - a$1 * b$3,
            a$1 * b$2 - a$2 * b$1]"

end

bundle cross3_syntax begin
notation cross3 (infixr "\<times>" 80)
no_notation Product_Type.Times (infixr "\<times>" 80)
end

bundle no_cross3_syntax begin
no_notation cross3 (infixr "\<times>" 80)
notation Product_Type.Times (infixr "\<times>" 80)
end

unbundle cross3_syntax

subsection\<open> Basic lemmas\<close>

lemmas cross3_simps = cross3_def inner_vec_def sum_3 det_3 vec_eq_iff vector_def algebra_simps

lemma dot_cross_self: "x \<bullet> (x \<times> y) = 0" "x \<bullet> (y \<times> x) = 0" "(x \<times> y) \<bullet> y = 0" "(y \<times> x) \<bullet> y = 0"
  by (simp_all add: orthogonal_def cross3_simps)

lemma  orthogonal_cross: "orthogonal (x \<times> y) x" "orthogonal (x \<times> y) y"
                        "orthogonal y (x \<times> y)" "orthogonal (x \<times> y) x"
  by (simp_all add: orthogonal_def dot_cross_self)

lemma  cross_zero_left [simp]: "0 \<times> x = 0" and cross_zero_right [simp]: "x \<times> 0 = 0" for x::"real^3"
  by (simp_all add: cross3_simps)

lemma  cross_skew: "(x \<times> y) = -(y \<times> x)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_refl [simp]: "x \<times> x = 0" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_add_left: "(x + y) \<times> z = (x \<times> z) + (y \<times> z)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_add_right: "x \<times> (y + z) = (x \<times> y) + (x \<times> z)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_mult_left: "(c *\<^sub>R x) \<times> y = c *\<^sub>R (x \<times> y)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_mult_right: "x \<times> (c *\<^sub>R y) = c *\<^sub>R (x \<times> y)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_minus_left [simp]: "(-x) \<times> y = - (x \<times> y)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  cross_minus_right [simp]: "x \<times> -y = - (x \<times> y)" for x::"real^3"
  by (simp add: cross3_simps)

lemma  left_diff_distrib: "(x - y) \<times> z = x \<times> z - y \<times> z" for x::"real^3"
  by (simp add: cross3_simps)

lemma  right_diff_distrib: "x \<times> (y - z) = x \<times> y - x \<times> z" for x::"real^3"
  by (simp add: cross3_simps)

hide_fact (open) left_diff_distrib right_diff_distrib

proposition Jacobi: "x \<times> (y \<times> z) + y \<times> (z \<times> x) + z \<times> (x \<times> y) = 0" for x::"real^3"
  by (simp add: cross3_simps)

proposition Lagrange: "x \<times> (y \<times> z) = (x \<bullet> z) *\<^sub>R y - (x \<bullet> y) *\<^sub>R z"
  by (simp add: cross3_simps) (metis (full_types) exhaust_3)

proposition cross_triple: "(x \<times> y) \<bullet> z = (y \<times> z) \<bullet> x"
  by (simp add: cross3_def inner_vec_def sum_3 vec_eq_iff algebra_simps)

lemma  cross_components:
   "(x \<times> y)$1 = x$2 * y$3 - y$2 * x$3" "(x \<times> y)$2 = x$3 * y$1 - y$3 * x$1" "(x \<times> y)$3 = x$1 * y$2 - y$1 * x$2"
  by (simp_all add: cross3_def inner_vec_def sum_3 vec_eq_iff algebra_simps)

lemma  cross_basis: "(axis 1 1) \<times> (axis 2 1) = axis 3 1" "(axis 2 1) \<times> (axis 1 1) = -(axis 3 1)"
                   "(axis 2 1) \<times> (axis 3 1) = axis 1 1" "(axis 3 1) \<times> (axis 2 1) = -(axis 1 1)"
                   "(axis 3 1) \<times> (axis 1 1) = axis 2 1" "(axis 1 1) \<times> (axis 3 1) = -(axis 2 1)"
  using exhaust_3
  by (force simp add: axis_def cross3_simps)+

lemma  cross_basis_nonzero:
  "u \<noteq> 0 \<Longrightarrow> u \<times> axis 1 1 \<noteq> 0 \<or> u \<times> axis 2 1 \<noteq> 0 \<or> u \<times> axis 3 1 \<noteq> 0"
  by (clarsimp simp add: axis_def cross3_simps) (metis exhaust_3)

lemma  cross_dot_cancel:
  fixes x::"real^3"
  assumes deq: "x \<bullet> y = x \<bullet> z" and veq: "x \<times> y = x \<times> z" and x: "x \<noteq> 0"
  shows "y = z"
proof -
  have "x \<bullet> x \<noteq> 0"
    by (simp add: x)
  then have "y - z = 0"
    using veq
    by (metis (no_types, lifting) Cross3.right_diff_distrib Lagrange deq eq_iff_diff_eq_0 inner_diff_right scale_eq_0_iff)
  then show ?thesis
    using eq_iff_diff_eq_0 by blast
qed

lemma  norm_cross_dot: "(norm (x \<times> y))\<^sup>2 + (x \<bullet> y)\<^sup>2 = (norm x * norm y)\<^sup>2"
  unfolding power2_norm_eq_inner power_mult_distrib
  by (simp add: cross3_simps power2_eq_square)

lemma  dot_cross_det: "x \<bullet> (y \<times> z) = det(vector[x,y,z])"
  by (simp add: cross3_simps)

lemma  cross_cross_det: "(w \<times> x) \<times> (y \<times> z) = det(vector[w,x,z]) *\<^sub>R y - det(vector[w,x,y]) *\<^sub>R z"
  using exhaust_3 by (force simp add: cross3_simps)

proposition  dot_cross: "(w \<times> x) \<bullet> (y \<times> z) = (w \<bullet> y) * (x \<bullet> z) - (w \<bullet> z) * (x \<bullet> y)"
  by (force simp add: cross3_simps)

proposition  norm_cross: "(norm (x \<times> y))\<^sup>2 = (norm x)\<^sup>2 * (norm y)\<^sup>2 - (x \<bullet> y)\<^sup>2"
  unfolding power2_norm_eq_inner power_mult_distrib
  by (simp add: cross3_simps power2_eq_square)

lemma  cross_eq_0: "x \<times> y = 0 \<longleftrightarrow> collinear{0,x,y}"
proof -
  have "x \<times> y = 0 \<longleftrightarrow> norm (x \<times> y) = 0"
    by simp
  also have "... \<longleftrightarrow> (norm x * norm y)\<^sup>2 = (x \<bullet> y)\<^sup>2"
    using norm_cross [of x y] by (auto simp: power_mult_distrib)
  also have "... \<longleftrightarrow> \<bar>x \<bullet> y\<bar> = norm x * norm y"
    using power2_eq_iff
    by (metis (mono_tags, opaque_lifting) abs_minus abs_norm_cancel abs_power2 norm_mult power_abs real_norm_def)
  also have "... \<longleftrightarrow> collinear {0, x, y}"
    by (rule norm_cauchy_schwarz_equal)
  finally show ?thesis .
qed

lemma  cross_eq_self: "x \<times> y = x \<longleftrightarrow> x = 0" "x \<times> y = y \<longleftrightarrow> y = 0"
  apply (metis cross_zero_left dot_cross_self(1) inner_eq_zero_iff)
  by (metis cross_zero_right dot_cross_self(2) inner_eq_zero_iff)

lemma  norm_and_cross_eq_0:
   "x \<bullet> y = 0 \<and> x \<times> y = 0 \<longleftrightarrow> x = 0 \<or> y = 0" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (metis cross_dot_cancel cross_zero_right inner_zero_right)
qed auto

lemma  bilinear_cross: "bilinear(\<times>)"
  apply (auto simp add: bilinear_def linear_def)
  apply unfold_locales
  apply (simp add: cross_add_right)
  apply (simp add: cross_mult_right)
  apply (simp add: cross_add_left)
  apply (simp add: cross_mult_left)
  done

subsection   \<open>Preservation by rotation, or other orthogonal transformation up to sign\<close>

lemma  cross_matrix_mult: "transpose A *v ((A *v x) \<times> (A *v y)) = det A *\<^sub>R (x \<times> y)"
  apply (simp add: vec_eq_iff   )
  apply (simp add: vector_matrix_mult_def matrix_vector_mult_def forall_3 cross3_simps)
  done

lemma  cross_orthogonal_matrix:
  assumes "orthogonal_matrix A"
  shows "(A *v x) \<times> (A *v y) = det A *\<^sub>R (A *v (x \<times> y))"
proof -
  have "mat 1 = transpose (A ** transpose A)"
    by (metis (no_types) assms orthogonal_matrix_def transpose_mat)
  then show ?thesis
    by (metis (no_types) vector_matrix_mul_rid vector_transpose_matrix cross_matrix_mult matrix_vector_mul_assoc matrix_vector_mult_scaleR)
qed

lemma  cross_rotation_matrix: "rotation_matrix A \<Longrightarrow> (A *v x) \<times> (A *v y) =  A *v (x \<times> y)"
  by (simp add: rotation_matrix_def cross_orthogonal_matrix)

lemma  cross_rotoinversion_matrix: "rotoinversion_matrix A \<Longrightarrow> (A *v x) \<times> (A *v y) = - A *v (x \<times> y)"
  by (simp add: rotoinversion_matrix_def cross_orthogonal_matrix scaleR_matrix_vector_assoc)

lemma  cross_orthogonal_transformation:
  assumes "orthogonal_transformation f"
  shows   "(f x) \<times> (f y) = det(matrix f) *\<^sub>R f(x \<times> y)"
proof -
  have orth: "orthogonal_matrix (matrix f)"
    using assms orthogonal_transformation_matrix by blast
  have "matrix f *v z = f z" for z
    using assms orthogonal_transformation_matrix by force
  with cross_orthogonal_matrix [OF orth] show ?thesis
    by simp
qed

lemma  cross_linear_image:
   "\<lbrakk>linear f; \<And>x. norm(f x) = norm x; det(matrix f) = 1\<rbrakk>
           \<Longrightarrow> (f x) \<times> (f y) = f(x \<times> y)"
  by (simp add: cross_orthogonal_transformation orthogonal_transformation)

subsection \<open>Continuity\<close>

lemma  continuous_cross: "\<lbrakk>continuous F f; continuous F g\<rbrakk> \<Longrightarrow> continuous F (\<lambda>x. (f x) \<times> (g x))"
  apply (subst continuous_componentwise)
  apply (clarsimp simp add: cross3_simps)
  apply (intro continuous_intros; simp)
  done

lemma  continuous_on_cross:
  fixes f :: "'a::t2_space \<Rightarrow> real^3"
  shows "\<lbrakk>continuous_on S f; continuous_on S g\<rbrakk> \<Longrightarrow> continuous_on S (\<lambda>x. (f x) \<times> (g x))"
  by (simp add: continuous_on_eq_continuous_within continuous_cross)

unbundle no_cross3_syntax

end