(*
  File:         PAC_Specification.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Specification
  imports PAC_More_Poly
begin

section \<open>Specification of the PAC checker\<close>

subsection \<open>Ideals\<close>

type_synonym int_poly = \<open>int mpoly\<close>
definition polynomial_bool :: \<open>int_poly set\<close> where
  \<open>polynomial_bool = (\<lambda>c. Var c ^ 2 - Var c) ` UNIV\<close>

definition pac_ideal where
  \<open>pac_ideal A \<equiv> ideal (A \<union> polynomial_bool)\<close>

lemma X2_X_in_pac_ideal:
  \<open>Var c ^ 2 - Var c \<in> pac_ideal A\<close>
  unfolding polynomial_bool_def pac_ideal_def
  by (auto intro: ideal.span_base)

lemma pac_idealI1[intro]:
  \<open>p \<in> A \<Longrightarrow> p \<in> pac_ideal A\<close>
  unfolding pac_ideal_def
  by (auto intro: ideal.span_base)

lemma pac_idealI2[intro]:
  \<open>p \<in> ideal A \<Longrightarrow> p \<in> pac_ideal A\<close>
  using ideal.span_subspace_induct pac_ideal_def by blast

lemma pac_idealI3[intro]:
  \<open>p \<in> ideal A \<Longrightarrow> p*q \<in> pac_ideal A\<close>
  by (metis ideal.span_scale mult.commute pac_idealI2)

lemma diff_in_polynomial_bool_pac_idealI:
   assumes a1: "p \<in> pac_ideal A"
   assumes a2: "p - p' \<in> More_Modules.ideal polynomial_bool"
   shows \<open>p' \<in> pac_ideal A\<close>
 proof -
   have "insert p polynomial_bool \<subseteq> pac_ideal A"
     using a1 unfolding pac_ideal_def by (meson ideal.span_superset insert_subset le_sup_iff)
   then show ?thesis
     using a2 unfolding pac_ideal_def by (metis (no_types) ideal.eq_span_insert_eq ideal.span_subset_spanI ideal.span_superset insert_subset subsetD)
qed

lemma diff_in_polynomial_bool_pac_idealI2:
   assumes a1: "p \<in> A"
   assumes a2: "p - p' \<in> More_Modules.ideal polynomial_bool"
   shows \<open>p' \<in> pac_ideal A\<close>
   using diff_in_polynomial_bool_pac_idealI[OF _ assms(2), of A] assms(1)
   by (auto simp: ideal.span_base)

lemma pac_ideal_alt_def:
  \<open>pac_ideal A = ideal (A \<union> ideal polynomial_bool)\<close>
  unfolding pac_ideal_def
  by (meson ideal.span_eq ideal.span_mono ideal.span_superset le_sup_iff subset_trans sup_ge2)

text \<open>

  The equality on ideals is restricted to polynomials whose variable
  appear in the set of ideals. The function restrict sets:

\<close>
definition restricted_ideal_to where
  \<open>restricted_ideal_to B A = {p \<in> A. vars p  \<subseteq> B}\<close>

abbreviation restricted_ideal_to\<^sub>I where
  \<open>restricted_ideal_to\<^sub>I B A \<equiv> restricted_ideal_to B (pac_ideal (set_mset A))\<close>

abbreviation restricted_ideal_to\<^sub>V where
  \<open>restricted_ideal_to\<^sub>V B \<equiv> restricted_ideal_to (\<Union>(vars ` set_mset B))\<close>

abbreviation restricted_ideal_to\<^sub>V\<^sub>I where
  \<open>restricted_ideal_to\<^sub>V\<^sub>I B A \<equiv> restricted_ideal_to (\<Union>(vars ` set_mset B)) (pac_ideal (set_mset A))\<close>

lemma restricted_idealI:
  \<open>p \<in> pac_ideal (set_mset A) \<Longrightarrow> vars p \<subseteq> C \<Longrightarrow> p \<in> restricted_ideal_to\<^sub>I C A\<close>
  unfolding restricted_ideal_to_def
  by auto

lemma pac_ideal_insert_already_in:
  \<open>pq \<in> pac_ideal (set_mset A) \<Longrightarrow> pac_ideal (insert pq (set_mset A)) = pac_ideal (set_mset A)\<close>
  by (auto simp: pac_ideal_alt_def ideal.span_insert_idI)

lemma pac_ideal_add:
  \<open>p \<in># A \<Longrightarrow> q \<in># A \<Longrightarrow> p + q \<in> pac_ideal (set_mset A)\<close>
  by (simp add: ideal.span_add ideal.span_base pac_ideal_def)
lemma pac_ideal_mult:
  \<open>p \<in># A \<Longrightarrow> p * q \<in> pac_ideal (set_mset A)\<close>
  by (simp add: ideal.span_base pac_idealI3)

lemma pac_ideal_mono:
  \<open>A \<subseteq> B \<Longrightarrow> pac_ideal A \<subseteq> pac_ideal B\<close>
  using ideal.span_mono[of \<open>A \<union> _\<close> \<open>B \<union> _\<close>]
  by (auto simp: pac_ideal_def intro: ideal.span_mono)

subsection \<open>PAC Format\<close>

text \<open>The PAC format contains three kind of steps:
  \<^item> \<^verbatim>\<open>add\<close> that adds up two polynomials that are known.
  \<^item> \<^verbatim>\<open>mult\<close> that multiply a known polynomial with another one.
  \<^item> \<^verbatim>\<open>del\<close> that removes a polynomial that cannot be reused anymore.

To model the simplification that happens, we add the \<^term>\<open>p - p' \<in> polynomial_bool\<close>
stating that \<^term>\<open>p\<close> and  \<^term>\<open>p'\<close> are equivalent.
\<close>

type_synonym pac_st = \<open>(nat set \<times> int_poly multiset)\<close>

inductive PAC_Format :: \<open>pac_st \<Rightarrow> pac_st \<Rightarrow> bool\<close> where
add:
  \<open>PAC_Format (\<V>, A) (\<V>, add_mset p' A)\<close>
if
   \<open>p \<in># A\<close> \<open>q \<in># A\<close>
   \<open>p+q - p' \<in> ideal polynomial_bool\<close>
   \<open>vars p' \<subseteq> \<V>\<close> |
mult:
  \<open>PAC_Format (\<V>, A) (\<V>, add_mset p' A)\<close>
if
   \<open>p \<in># A\<close>
   \<open>p*q - p' \<in> ideal polynomial_bool\<close>
   \<open>vars p' \<subseteq> \<V>\<close>
   \<open>vars q \<subseteq> \<V>\<close> |
del:
   \<open>p \<in># A \<Longrightarrow> PAC_Format (\<V>, A) (\<V>, A - {#p#})\<close> |
extend_pos:
  \<open>PAC_Format (\<V>, A) (\<V> \<union> {x' \<in> vars (-Var x + p'). x' \<notin> \<V>}, add_mset (-Var x + p') A)\<close>
  if
    \<open>(p')\<^sup>2 - p' \<in> ideal polynomial_bool\<close>
    \<open>vars p' \<subseteq> \<V>\<close>
    \<open>x \<notin> \<V>\<close>

text  \<open>
  In the PAC format above, we have a technical condition on the
  normalisation: \<^term>\<open>vars p' \<subseteq> vars (p + q)\<close> is here to ensure that
  we don't normalise \<^term>\<open>0 :: int mpoly\<close> to  \<^term>\<open>Var x^2 - Var x :: int mpoly\<close>
  for a new variable \<^term>\<open>x :: nat\<close>. This is completely obvious for the normalisation
  process we have in mind when we write the specification, but we must add it
  explicitly because we are too general.
\<close>

lemmas  PAC_Format_induct_split =
   PAC_Format.induct[split_format(complete), of V A V' A' for V A V' A']

lemma PAC_Format_induct[consumes 1, case_names add mult del ext]:
  assumes
    \<open>PAC_Format (\<V>, A) (\<V>', A')\<close> and
    cases:
      \<open>\<And>p q p'  A \<V>. p \<in># A \<Longrightarrow> q \<in># A \<Longrightarrow> p+q - p' \<in> ideal polynomial_bool \<Longrightarrow> vars p' \<subseteq> \<V> \<Longrightarrow> P \<V> A \<V> (add_mset p' A)\<close>
      \<open>\<And>p q p' A \<V>. p \<in># A \<Longrightarrow> p*q - p' \<in> ideal polynomial_bool \<Longrightarrow> vars p' \<subseteq> \<V> \<Longrightarrow> vars q \<subseteq> \<V> \<Longrightarrow>
        P \<V> A \<V> (add_mset p' A)\<close>
      \<open>\<And>p A \<V>. p \<in># A \<Longrightarrow> P \<V> A \<V> (A - {#p#})\<close>
      \<open>\<And>p' x r.
        (p')^2 - (p') \<in> ideal polynomial_bool \<Longrightarrow> vars p' \<subseteq> \<V> \<Longrightarrow>
        x \<notin> \<V> \<Longrightarrow> P \<V> A (\<V> \<union> {x' \<in> vars (p' - Var x). x' \<notin> \<V>}) (add_mset (p' -Var x) A)\<close>
  shows
     \<open>P \<V> A \<V>' A'\<close>
  using assms(1) apply -
  by (induct V\<equiv>\<V> A\<equiv>A \<V>' A' rule: PAC_Format_induct_split)
   (auto intro: assms(1) cases)

text \<open>

The theorem below (based on the proof ideal by Manuel Kauers) is the
correctness theorem of extensions. Remark that the assumption \<^term>\<open>vars
q \<subseteq> \<V>\<close> is only used to show that \<^term>\<open>x' \<notin> vars q\<close>.

\<close>
lemma extensions_are_safe:
  assumes \<open>x' \<in> vars p\<close> and
    x': \<open>x' \<notin> \<V>\<close> and
    \<open>\<Union> (vars ` set_mset A) \<subseteq> \<V>\<close> and
    p_x_coeff: \<open>coeff p (monomial (Suc 0) x') = 1\<close> and
    vars_q: \<open>vars q \<subseteq> \<V>\<close> and
    q: \<open>q \<in> More_Modules.ideal (insert p (set_mset A \<union> polynomial_bool))\<close> and
    leading: \<open>x' \<notin> vars (p - Var x')\<close> and
    diff: \<open>(Var x' - p)\<^sup>2 - (Var x' - p) \<in> More_Modules.ideal polynomial_bool\<close>
  shows
    \<open>q \<in> More_Modules.ideal (set_mset A \<union> polynomial_bool)\<close>
proof -
  define p' where \<open>p' \<equiv> p - Var x'\<close>
  let ?v = \<open>Var x' :: int mpoly\<close>
  have p_p': \<open>p = ?v + p'\<close>
    by (auto simp: p'_def)
  define q' where \<open>q' \<equiv> Var x' - p\<close>
  have q_q': \<open>p = ?v - q'\<close>
    by (auto simp: q'_def)
  have diff: \<open>q'^2 - q' \<in> More_Modules.ideal polynomial_bool\<close>
    using diff unfolding q_q' by auto

  have [simp]: \<open>vars ((Var c)\<^sup>2 - Var c :: int mpoly) = {c}\<close> for c
    apply (auto simp: vars_def Var_def Var\<^sub>0_def mpoly.MPoly_inverse keys_def lookup_minus_fun
      lookup_times_monomial_right single.rep_eq split: if_splits)
    apply (auto simp: vars_def Var_def Var\<^sub>0_def mpoly.MPoly_inverse keys_def lookup_minus_fun
      lookup_times_monomial_right single.rep_eq when_def ac_simps adds_def lookup_plus_fun
      power2_eq_square times_mpoly.rep_eq minus_mpoly.rep_eq split: if_splits)
    apply (rule_tac x = \<open>(2 :: nat \<Rightarrow>\<^sub>0 nat) * monomial (Suc 0) c\<close> in exI)
    apply (auto dest: monomial_0D simp: plus_eq_zero_2 lookup_plus_fun mult_2)
    by (meson Suc_neq_Zero monomial_0D plus_eq_zero_2)

  have eq: \<open>More_Modules.ideal (insert p (set_mset A \<union> polynomial_bool)) =
      More_Modules.ideal (insert p (set_mset A \<union> (\<lambda>c. Var c ^ 2 - Var c) ` {c. c \<noteq> x'}))\<close>
      (is \<open>?A = ?B\<close> is \<open>_ = More_Modules.ideal ?trimmed\<close>)
  proof -
     let ?C = \<open>insert p (set_mset A \<union> (\<lambda>c. Var c ^ 2 - Var c) ` {c. c \<noteq> x'})\<close>
     let ?D = \<open>(\<lambda>c. Var c ^ 2 - Var c) ` {c. c \<noteq> x'}\<close>
     have diff: \<open>q'^2 - q' \<in> More_Modules.ideal ?D\<close> (is \<open>?q \<in> _\<close>)
     proof -
       obtain r t where
         q: \<open>?q = (\<Sum>a\<in>t. r a * a)\<close> and
         fin_t: \<open>finite t\<close> and
         t: \<open>t \<subseteq> polynomial_bool\<close>
         using diff unfolding ideal.span_explicit
         by auto
       show ?thesis
       proof (cases \<open>?v^2-?v \<notin> t\<close>)
         case True
         then show \<open>?thesis\<close>
           using q fin_t t unfolding ideal.span_explicit
           by (auto intro!: exI[of _ \<open>t - {?v^2 -?v}\<close>] exI[of _ r]
             simp: polynomial_bool_def sum_diff1)
        next
          case False
          define t' where \<open>t' = t - {?v^2 - ?v}\<close>
          have t_t': \<open>t = insert (?v^2 - ?v) t'\<close> and
            notin: \<open>?v^2 - ?v \<notin> t'\<close> and
            \<open>t' \<subseteq> (\<lambda>c. Var c ^ 2 - Var c) ` {c. c \<noteq> x'}\<close>
            using False t unfolding t'_def polynomial_bool_def by auto
          have mon: \<open>monom (monomial (Suc 0) x') 1 = Var x'\<close>
            by (auto simp: coeff_def minus_mpoly.rep_eq Var_def Var\<^sub>0_def monom_def
              times_mpoly.rep_eq lookup_minus lookup_times_monomial_right mpoly.MPoly_inverse)
          then have \<open>\<forall>a. \<exists>g h. r a = ?v * g + h \<and> x' \<notin> vars h\<close>
            using polynomial_split_on_var[of \<open>r _\<close> x']
            by metis
          then obtain g h where
            r: \<open>r a = ?v * g a + h a\<close> and
            x'_h: \<open>x' \<notin> vars (h a)\<close> for a
            using polynomial_split_on_var[of \<open>r a\<close> x']
            by metis
          have  \<open>?q = ((\<Sum>a\<in>t'. g a * a) + r (?v^2-?v) * (?v - 1)) * ?v + (\<Sum>a\<in>t'. h a * a)\<close>
            using fin_t notin unfolding t_t' q r
            by (auto simp: field_simps comm_monoid_add_class.sum.distrib
              power2_eq_square ideal.scale_left_commute sum_distrib_left)
          moreover have \<open>x' \<notin> vars ?q\<close>
            by (metis (no_types, opaque_lifting) Groups.add_ac(2) Un_iff add_diff_cancel_left'
              diff_minus_eq_add in_mono leading q'_def semiring_normalization_rules(29)
              vars_in_right_only vars_mult)
          moreover {
            have \<open>x' \<notin> (\<Union>m\<in>t' - {?v^2-?v}. vars (h m * m))\<close>
              using fin_t x'_h vars_mult[of \<open>h _\<close>] \<open>t \<subseteq> polynomial_bool\<close>
              by (auto simp: polynomial_bool_def t_t' elim!: vars_unE)
            then have \<open>x' \<notin> vars (\<Sum>a\<in>t'. h a * a)\<close>
              using vars_setsum[of \<open>t'\<close> \<open>\<lambda>a. h a * a\<close>] fin_t x'_h t notin
              by (auto simp: t_t')
          }
          ultimately have \<open>?q = (\<Sum>a\<in>t'. h a * a)\<close>
            unfolding mon[symmetric]
            by (rule polynomial_decomp_alien_var(2)[unfolded])
          then show ?thesis
            using t fin_t \<open>t' \<subseteq> (\<lambda>c. Var c ^ 2 - Var c) ` {c. c \<noteq> x'}\<close>
            unfolding ideal.span_explicit t_t'
            by auto
       qed
    qed
    have eq1: \<open>More_Modules.ideal (insert p (set_mset A \<union> polynomial_bool)) =
      More_Modules.ideal (insert (?v^2 - ?v) ?C)\<close>
      (is \<open>More_Modules.ideal _ = More_Modules.ideal (insert _ ?C)\<close>)
      by (rule arg_cong[of _ _ More_Modules.ideal])
       (auto simp: polynomial_bool_def)
    moreover have \<open>?v^2 - ?v \<in> More_Modules.ideal ?C\<close>
    proof -
      have \<open>?v - q' \<in> More_Modules.ideal ?C\<close>
        by (auto simp: q_q' ideal.span_base)
      from ideal.span_scale[OF this, of \<open>?v + q' - 1\<close>] have \<open>(?v - q') * (?v + q' - 1) \<in> More_Modules.ideal ?C\<close>
        by (auto simp: field_simps)
      moreover have \<open>q'^2 - q' \<in> More_Modules.ideal ?C\<close>
        using diff by (smt (verit) Un_insert_right ideal.span_mono insert_subset subsetD sup_ge2)
      ultimately have \<open>(?v - q') * (?v + q' - 1) + (q'^2 - q') \<in> More_Modules.ideal ?C\<close>
        by (rule ideal.span_add)
      moreover have \<open>?v^2 - ?v = (?v - q') * (?v + q' - 1) + (q'^2 - q')\<close>
        by (auto simp: p'_def q_q' field_simps power2_eq_square)
      ultimately show ?thesis by simp
    qed
    ultimately show ?thesis
      using ideal.span_insert_idI by blast
  qed

  have \<open>n < m \<Longrightarrow> n > 0 \<Longrightarrow> \<exists>q. ?v^n = ?v + q * (?v^2 - ?v)\<close> for n m :: nat
  proof (induction m arbitrary: n)
    case 0
    then show ?case by auto
  next
    case (Suc m n) note IH = this(1-)
    consider
      \<open>n < m\<close> |
      \<open>m = n\<close> \<open>n > 1\<close> |
      \<open>n = 1\<close>
      using IH
      by (cases \<open>n < m\<close>; cases n) auto
    then show ?case
    proof cases
      case 1
      then show ?thesis using IH by auto
    next
      case 2
      have eq: \<open>?v^(n) = ((?v :: int mpoly) ^ (n-2)) * (?v^2-?v) + ?v^(n-1)\<close>
        using 2 by (auto simp: field_simps power_eq_if
          ideal.scale_right_diff_distrib)
      obtain q where
        q: \<open>?v^(n-1) = ?v + q * (?v^2 - ?v)\<close>
        using IH(1)[of \<open>n-1\<close>] 2
        by auto
      show ?thesis
        using q unfolding eq
        by (auto intro!: exI[of _ \<open>Var x' ^ (n - 2) + q\<close>] simp: distrib_right)
    next
      case 3
      then show \<open>?thesis\<close>
        by auto
    qed
  qed

  obtain r t where
    q: \<open>q = (\<Sum>a\<in>t. r a * a)\<close> and
    fin_t: \<open>finite t\<close> and
    t: \<open>t \<subseteq> ?trimmed\<close>
    using q unfolding eq unfolding ideal.span_explicit
    by auto

  define t' where \<open>t' \<equiv> t - {p}\<close>
  have t': \<open>t = (if p \<in> t then insert p t' else t')\<close> and
    t''[simp]: \<open>p \<notin> t'\<close>
    unfolding t'_def by auto
  show ?thesis
  proof (cases \<open>r p = 0 \<or> p \<notin> t\<close>)
    case True
    have
      q: \<open>q = (\<Sum>a\<in>t'. r a * a)\<close> and
     fin_t: \<open>finite t'\<close> and
      t: \<open>t' \<subseteq> set_mset A \<union> polynomial_bool\<close>
      using q fin_t t True t''
      apply (subst (asm) t')
      apply (auto intro: sum.cong simp: sum.insert_remove t'_def)
      using q fin_t t True t''
      apply (auto intro: sum.cong simp: sum.insert_remove t'_def polynomial_bool_def)
      done
    then show ?thesis
      by (auto simp: ideal.span_explicit)
  next
    case False
    then have \<open>r p \<noteq> 0\<close> and \<open>p \<in> t\<close>
      by auto
    then have t: \<open>t = insert p t'\<close>
      by (auto simp: t'_def)

   have \<open>x' \<notin> vars (- p')\<close>
     using leading p'_def vars_in_right_only by fastforce
   have mon: \<open>monom (monomial (Suc 0) x') 1 = Var x'\<close>
     by (auto simp:coeff_def minus_mpoly.rep_eq Var_def Var\<^sub>0_def monom_def
       times_mpoly.rep_eq lookup_minus lookup_times_monomial_right mpoly.MPoly_inverse)
   then have \<open>\<forall>a. \<exists>g h. r a = (?v + p') * g + h \<and> x' \<notin> vars h\<close>
     using polynomial_split_on_var2[of x' \<open>-p'\<close> \<open>r _\<close>]  \<open>x' \<notin> vars (- p')\<close>
     by (metis diff_minus_eq_add)
   then obtain g h where
     r: \<open>r a = p * g a + h a\<close> and
     x'_h: \<open>x' \<notin> vars (h a)\<close> for a
     using polynomial_split_on_var2[of x' p' \<open>r a\<close>] unfolding p_p'[symmetric]
     by metis

  have ISABLLE_come_on: \<open>a * (p * g a) = p * (a * g a)\<close> for a
    by auto
  have q1: \<open>q = p * (\<Sum>a\<in>t'. g a * a) + (\<Sum>a\<in>t'. h a * a) + p * r p\<close>
    (is \<open>_ = _ + ?NOx' + _\<close>)
    using fin_t t'' unfolding q t ISABLLE_come_on r
    apply (subst semiring_class.distrib_right)+
    apply (auto simp: comm_monoid_add_class.sum.distrib semigroup_mult_class.mult.assoc
      ISABLLE_come_on simp flip: semiring_0_class.sum_distrib_right
         semiring_0_class.sum_distrib_left)
    by (auto simp: field_simps)
  also have \<open>... = ((\<Sum>a\<in>t'. g a * a) + r p) * p + (\<Sum>a\<in>t'. h a * a)\<close>
    by (auto simp: field_simps)
  finally have q_decomp: \<open>q = ((\<Sum>a\<in>t'. g a * a) + r p) * p + (\<Sum>a\<in>t'. h a * a)\<close>
    (is \<open>q = ?X * p + ?NOx'\<close>).

   have [iff]: \<open>monomial (Suc 0) c = 0 - monomial (Suc 0) c = False\<close> for c
     by (metis One_nat_def diff_is_0_eq' le_eq_less_or_eq less_Suc_eq_le monomial_0_iff single_diff zero_neq_one)
  have \<open>x \<in> t' \<Longrightarrow> x' \<in> vars x \<Longrightarrow> False\<close> for x
    using  \<open>t \<subseteq> ?trimmed\<close> t assms(2,3)
    apply (auto simp: polynomial_bool_def dest!: multi_member_split)
    apply (frule set_rev_mp)
    apply assumption
    apply (auto dest!: multi_member_split)
    done
   then have \<open>x' \<notin> (\<Union>m\<in>t'. vars (h m * m))\<close>
     using fin_t x'_h vars_mult[of \<open>h _\<close>]
     by (auto simp: t elim!: vars_unE)
   then have \<open>x' \<notin> vars ?NOx'\<close>
     using vars_setsum[of \<open>t'\<close> \<open>\<lambda>a. h a * a\<close>] fin_t x'_h
     by (auto simp: t)

  moreover {
    have \<open>x' \<notin> vars p'\<close>
      using assms(7)
      unfolding p'_def
      by auto
    then have \<open>x' \<notin> vars (h p * p')\<close>
      using vars_mult[of \<open>h p\<close> p'] x'_h
      by auto
  }
  ultimately have
    \<open>x' \<notin> vars q\<close>
    \<open>x' \<notin> vars ?NOx'\<close>
    \<open>x' \<notin> vars p'\<close>
    using x' vars_q vars_add[of \<open>h p * p'\<close> \<open>\<Sum>a\<in>t'. h a * a\<close>] x'_h
      leading p'_def
    by auto
  then have \<open>?X = 0\<close> and q_decomp: \<open>q = ?NOx'\<close>
    unfolding mon[symmetric] p_p'
    using polynomial_decomp_alien_var2[OF q_decomp[unfolded p_p' mon[symmetric]]]
    by auto

  then have \<open>r p = (\<Sum>a\<in>t'. (- g a) * a)\<close>
    (is \<open>_ = ?CL\<close>)
    unfolding add.assoc add_eq_0_iff equation_minus_iff
    by (auto simp: sum_negf ac_simps)

  then have q2: \<open>q = (\<Sum>a\<in>t'. a * (r a - p * g a))\<close>
    using fin_t unfolding q
    apply (auto simp: t r q
         comm_monoid_add_class.sum.distrib[symmetric]
         sum_distrib_left
         sum_distrib_right
         left_diff_distrib
        intro!: sum.cong)
    apply (auto simp: field_simps)
    done
  then show \<open>?thesis\<close>
    using t fin_t \<open>t \<subseteq> ?trimmed\<close> unfolding ideal.span_explicit
    by (auto intro!: exI[of _ t'] exI[of _ \<open>\<lambda>a. r a - p * g a\<close>]
      simp: field_simps polynomial_bool_def)
  qed
qed

lemma extensions_are_safe_uminus:
  assumes \<open>x' \<in> vars p\<close> and
    x': \<open>x' \<notin> \<V>\<close> and
    \<open>\<Union> (vars ` set_mset A) \<subseteq> \<V>\<close> and
    p_x_coeff: \<open>coeff p (monomial (Suc 0) x') = -1\<close> and
    vars_q: \<open>vars q \<subseteq> \<V>\<close> and
    q: \<open>q \<in> More_Modules.ideal (insert p (set_mset A \<union> polynomial_bool))\<close> and
    leading: \<open>x' \<notin> vars (p + Var x')\<close> and
    diff: \<open>(Var x' + p)^2 - (Var x' + p) \<in> More_Modules.ideal polynomial_bool\<close>
  shows
    \<open>q \<in> More_Modules.ideal (set_mset A \<union> polynomial_bool)\<close>
proof -
  have \<open>q \<in> More_Modules.ideal (insert (- p) (set_mset A \<union> polynomial_bool))\<close>
    by (metis ideal.span_breakdown_eq minus_mult_minus q)

  then show ?thesis
    using extensions_are_safe[of x' \<open>-p\<close> \<V> A q] assms
    using vars_in_right_only by force
qed

text \<open>This is the correctness theorem of a PAC step: no polynomials are
added to the ideal.\<close>

lemma vars_subst_in_left_only:
  \<open>x \<notin> vars p \<Longrightarrow> x \<in> vars (p - Var x)\<close> for p :: \<open>int mpoly\<close>
  by (metis One_nat_def Var.abs_eq Var\<^sub>0_def group_eq_aux monom.abs_eq mult_numeral_1 polynomial_decomp_alien_var(1) zero_neq_numeral)

lemma vars_subst_in_left_only_diff_iff:
  fixes p :: \<open>int mpoly\<close>
  assumes \<open>x \<notin> vars p\<close>
  shows \<open>vars (p - Var x) = insert x (vars p)\<close>
proof -
  have \<open>\<And>xa. x \<notin> vars p \<Longrightarrow> xa \<in> vars (p - Var x) \<Longrightarrow> xa \<notin> vars p \<Longrightarrow> xa = x\<close>
    by (metis (no_types, opaque_lifting) diff_0_right diff_minus_eq_add empty_iff in_vars_addE insert_iff
      keys_single minus_diff_eq monom_one mult.right_neutral one_neq_zero single_zero
      vars_monom_keys vars_mult_Var vars_uminus)
  moreover have \<open>\<And>xa. x \<notin> vars p \<Longrightarrow> xa \<in> vars p \<Longrightarrow> xa \<in> vars (p - Var x)\<close>
    by (metis add.inverse_inverse diff_minus_eq_add empty_iff insert_iff keys_single minus_diff_eq
      monom_one mult.right_neutral one_neq_zero single_zero vars_in_right_only vars_monom_keys
      vars_mult_Var vars_uminus)
  ultimately show ?thesis
    using assms
    by (auto simp: vars_subst_in_left_only)
qed

lemma vars_subst_in_left_only_iff:
  \<open>x \<notin> vars p \<Longrightarrow> vars (p + Var x) = insert x (vars p)\<close> for p :: \<open>int mpoly\<close>
  using vars_subst_in_left_only_diff_iff[of x \<open>-p\<close>]
  by (metis diff_0 diff_diff_add vars_uminus)

lemma coeff_add_right_notin:
  \<open>x \<notin> vars p \<Longrightarrow> MPoly_Type.coeff (Var x - p) (monomial (Suc 0) x) = 1\<close>
  apply (auto simp flip: coeff_minus simp: not_in_vars_coeff0)
  by (simp add: MPoly_Type.coeff_def Var.rep_eq Var\<^sub>0_def)

lemma coeff_add_left_notin:
  \<open>x \<notin> vars p \<Longrightarrow> MPoly_Type.coeff (p - Var x) (monomial (Suc 0) x) = -1\<close> for p :: \<open>int mpoly\<close>
  apply (auto simp flip: coeff_minus simp: not_in_vars_coeff0)
  by (simp add: MPoly_Type.coeff_def Var.rep_eq Var\<^sub>0_def)

lemma ideal_insert_polynomial_bool_swap: \<open>r - s \<in> ideal polynomial_bool \<Longrightarrow>
  More_Modules.ideal (insert r  (A \<union> polynomial_bool)) = More_Modules.ideal (insert s (A \<union> polynomial_bool))\<close>
  apply auto
  using ideal.eq_span_insert_eq ideal.span_mono sup_ge2 apply blast+
  done

lemma PAC_Format_subset_ideal:
  \<open>PAC_Format (\<V>, A) (\<V>', B) \<Longrightarrow> \<Union>(vars ` set_mset A) \<subseteq> \<V> \<Longrightarrow>
     restricted_ideal_to\<^sub>I \<V> B \<subseteq> restricted_ideal_to\<^sub>I \<V> A \<and> \<V> \<subseteq> \<V>' \<and> \<Union>(vars ` set_mset B) \<subseteq> \<V>'\<close>
  unfolding restricted_ideal_to_def
  apply (induction rule:PAC_Format_induct)
  subgoal for p q pq A \<V>
    using vars_add
    by (force simp: ideal.span_add_eq ideal.span_base pac_ideal_insert_already_in[OF diff_in_polynomial_bool_pac_idealI[of \<open>p + q\<close> \<open>_\<close> pq]]
        pac_ideal_add
      intro!: diff_in_polynomial_bool_pac_idealI[of \<open>p + q\<close> \<open>_\<close> pq])
  subgoal for p q pq
    using vars_mult[of p q]
    by (force simp: ideal.span_add_eq ideal.span_base pac_ideal_mult
      pac_ideal_insert_already_in[OF diff_in_polynomial_bool_pac_idealI[of \<open>p*q\<close> \<open>_\<close> pq]])
  subgoal for p A
    using pac_ideal_mono[of \<open>set_mset (A - {#p#})\<close> \<open>set_mset A\<close>]
    by (auto dest: in_diffD)
  subgoal for p x' r'
    apply (subgoal_tac \<open>x' \<notin> vars p\<close>)
    using extensions_are_safe_uminus[of x' \<open>-Var x' + p\<close> \<V> A] unfolding pac_ideal_def
    apply (auto simp: vars_subst_in_left_only coeff_add_left_notin)
    done
  done

text \<open>
  In general, if deletions are disallowed, then the stronger \<^term>\<open>B = pac_ideal A\<close> holds.
\<close>
lemma restricted_ideal_to_restricted_ideal_to\<^sub>ID:
  \<open>restricted_ideal_to \<V> (set_mset A) \<subseteq> restricted_ideal_to\<^sub>I \<V> A\<close>
   by (auto simp add: Collect_disj_eq pac_idealI1 restricted_ideal_to_def)

lemma rtranclp_PAC_Format_subset_ideal:
  \<open>rtranclp PAC_Format (\<V>, A) (\<V>', B) \<Longrightarrow> \<Union>(vars ` set_mset A) \<subseteq> \<V> \<Longrightarrow>
     restricted_ideal_to\<^sub>I \<V> B \<subseteq> restricted_ideal_to\<^sub>I \<V> A \<and> \<V> \<subseteq> \<V>' \<and> \<Union>(vars ` set_mset B) \<subseteq> \<V>'\<close>
  apply (induction rule:rtranclp_induct[of PAC_Format \<open>(_, _)\<close> \<open>(_, _)\<close>, split_format(complete)])
  subgoal
    by (simp add: restricted_ideal_to_restricted_ideal_to\<^sub>ID)
  subgoal
    by (drule PAC_Format_subset_ideal)
      (auto simp: restricted_ideal_to_def Collect_mono_iff)
  done

end


theory Ex5_3
  imports Main
begin

datatype ('a , 'v) trie = Trie "'v option" "('a \<times> ('a  , 'v) trie) list"

primrec "value" :: "('a , 'v) trie \<Rightarrow> 'v option" where
"value (Trie ov al) = ov"

primrec alist ::  "('a , 'v)trie \<Rightarrow> ('a \<times> ('a , 'v)trie) list" where
"alist (Trie v ls) = ls"

primrec assoc :: "('key \<times> 'val)list \<Rightarrow> 'key \<Rightarrow> 'val option" where
"assoc [] x = None"|
"assoc (x#xs) key = (if key=  fst x then Some (snd x) else assoc xs key)"

primrec lookup :: "('a , 'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v option" where
"lookup t [] = value t"|
"lookup t (x#xs) = (case assoc (alist t) x of
  None \<Rightarrow> None |
  Some newT \<Rightarrow> lookup newT xs)"

primrec update :: "('a , 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a , 'v)trie" where
"update t [] val =  Trie (Some val) (alist t)"|
"update t (x#xs) val = (case assoc (alist t) x of
  None \<Rightarrow> Trie (value t) ((x , update (Trie None []) xs val) # alist t)|
  Some v \<Rightarrow> Trie  (value t) ((x , update v xs val) # alist t))"

lemma empty_tree_lookup : "lookup (Trie None []) ls = None" by (induction ls ; simp)

theorem "\<forall> t v bs. lookup (update t as v) bs = (if as = bs then Some v else lookup t bs)"
proof (induction as)
  case Nil
  then show ?case
  proof -
    {
      fix t::"('a , 'v)trie"
      fix v bs
      have "lookup (update t [] v) bs = (if [] = bs then Some v else lookup t bs)"
      proof (cases "bs")
        case Nil
        then show ?thesis by simp
      next
        case (Cons a list)
        then show ?thesis by simp
      qed
    }
    thus ?thesis by blast
  qed
next
  case (Cons a as)
  assume hyp:"\<forall>(t::('a,'v)trie) v bs. lookup (update t as v) bs = (if as = bs then Some v else lookup t bs)"
  then show " \<forall>(t::('a,'v)trie) v bs. lookup (update t (a # as) v) bs = (if a # as = bs then Some v else lookup t bs)"
  proof -
    {
      fix t::"('a , 'v)trie"
      fix bs v

      have "lookup (update t (a # as) v) bs = (if a # as = bs then Some v else lookup t bs) "
      proof (cases "bs")
        case Nil
        then show ?thesis by (cases "assoc (alist t) a" ; simp)
      next
        case (Cons aa list)
        assume c1:"bs = aa # list"
        then show ?thesis
        proof (cases "assoc (alist t) a")
          case None
          then show ?thesis
          proof (cases "a = aa")
            case True
            from hyp have tmp:"lookup (update (Trie None []) as v) list = (if as = list then Some v else lookup (Trie None []) list) " by simp

            have "lookup (update t (a # as) v) bs = lookup  (Trie (value t) ((a , update (Trie None []) as v) # alist t)) bs" using None by simp
            also have "\<dots> = lookup (update (Trie None []) as v) list" using c1 True None by simp
            also have "\<dots> = (if as = list then Some v else lookup (Trie None []) list)" using tmp by simp
            also have "\<dots> = (if a # as = bs then Some v else lookup (Trie None []) list)" using True c1 by simp
            also have "\<dots> = (if a # as = bs then Some v else lookup t bs)" using empty_tree_lookup c1 True None by auto
            finally show ?thesis by assumption
          next
            case False
            let ?tmp="update (Trie None []) as v"

            have "lookup (update t (a # as) v) bs = lookup (Trie (value t) ((a , ?tmp )  # alist t)) bs" using None by simp
            also have "\<dots> = lookup t bs" using False c1 by simp
            finally show ?thesis using c1 False by simp
          qed
        next
          case (Some aaa)
          then show ?thesis using c1 hyp by (cases "a = aa" ; simp)
        qed
      qed
    }
    then show " \<forall>(t::('a,'v)trie) v bs. lookup (update t (a # as) v) bs = (if a # as = bs then Some v else lookup t bs)"  by simp
  qed
qed

primrec modify :: "('a , 'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a , 'v)trie" where
"modify t [] v = Trie v (alist t)"|
"modify t (x#xs) v = (let tr  = (case assoc (alist t) x of
  None \<Rightarrow>  (x ,modify (Trie None []) xs v)   |
  Some t2 \<Rightarrow>  (x , modify t2 xs v)  )
  in Trie (value t) (tr # alist t))"

theorem "\<forall> t v bs. lookup (modify t as v) bs = (if as = bs then v else lookup t bs)"
proof (induction as)
case Nil
  then show ?case  using alist.simps  modify.simps(1) list.exhaust  lookup.simps  value.simps by metis
next
  case (Cons a as)
  assume hyp:"\<forall>(t::('a,'v)trie) (v::'v option) (bs::'a list). lookup (modify t as v) bs = (if as = bs then v else lookup t bs)"
  {
    fix t::"('a , 'v) trie"
    fix v bs
    have "lookup (modify t (a # as) v) bs = (if a # as = bs then v else lookup t bs)"
    proof (cases bs)
      case Nil
      then show ?thesis by simp
    next
      case (Cons aa list)
      show ?thesis
      proof (cases "assoc (alist t) a")
        case None
        from hyp have tmp:"lookup (modify (Trie None []) (as::'a list) v) (list :: 'a list) = (if as = list then v else lookup (Trie None []) list)" by simp
        then show ?thesis using Cons hyp None
        proof (cases "a = aa")
          case True
          have "lookup (modify t (a # as) v) bs = lookup  (modify (Trie None []) as v) list" using None Cons True  by simp
          also have "\<dots> = (if as = list then v else lookup (Trie None []) list)" using tmp by simp
          also have "\<dots> = (if a#as = bs then v else lookup t bs)" using Cons True None empty_tree_lookup by auto
          finally show ?thesis by assumption
        next
          case False
          then show ?thesis using Cons hyp None by simp
        qed
      next
        case (Some aaa)
        then show ?thesis using hyp Cons by (cases "a = aa" ; simp)
      qed
    qed
  }
  then show "\<forall>(t::('a,'v)trie) (v::'v option) bs. lookup (modify t (a # as) v) bs = (if a # as = bs then v else lookup t bs)" by simp
qed


(*<*)
theory tmpl06
  imports Main
begin
(*>*)

text {* \ExerciseSheet{6}{18.~5.~2018} *}

text \<open>\Exercise{Complexity of Naive Reverse}
  Show that the naive reverse function needs quadratically many
  \<open>Cons\<close> operations in the length of the input list.
  (Note that \<open>[x]\<close> is syntax sugar for \<open>Cons x []\<close>!)
\<close>

thm append.simps

fun reverse where
  "reverse [] = []"
| "reverse (x#xs) = reverse xs @ [x]"

(** Define cost functions and prove that they are equal to quadratic function *)

text \<open>
  \Exercise{Simple Paths}
  Recall the definition of paths from last exercise sheet:
\<close>
fun path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
  where
  "path G u [] v \<longleftrightarrow> u=v"
| "path G u (x#xs) v \<longleftrightarrow> G u x \<and> path G x xs v"

lemma path_append[simp]: "path G u (p1@p2) v \<longleftrightarrow> (\<exists>w. path G u p1 w \<and> path G w p2 v)"
  by (induction p1 arbitrary: u) auto

text \<open>
  A simple path is a path without loops, or, in other words, a path
  where no node occurs twice. (Note that the first node of the path is
  not included, such that there may be a simple path from \<open>u\<close> to \<open>u\<close>.)

  Show that for every path, there is a corresponding simple path.

  Hint: Induction on the length of the path
\<close>
thm measure_induct_rule[where f=length, case_names shorter]

thm not_distinct_decomp

lemma exists_simple_path:
  assumes "path G u p v"
  shows "\<exists>p'. path G u p' v \<and> distinct p'"
  oops

text \<open>\NumHomework{Stability of Insertion Sort}{May 25}
  Have a look at Isabelle's standard implementation of sorting: @{const sort_key}.
  (Use Ctrl-Click to jump to the definition in @{file "~~/src/HOL/List.thy"})
  Show that this function is a stable sorting algorithm, i.e., the order of elements
  with the same key is not changed during sorting!
\<close>

lemma "[x\<leftarrow>sort_key k xs. k x = a] = [x\<leftarrow>xs. k x = a]"
  oops

term "[x\<leftarrow>xs. P x]"
text \<open>
  Note: @{term [source] \<open>[x\<leftarrow>xs. P x] \<close>} is syntax sugar for @{term [source] \<open>filter P xs\<close>},
  where the filter function returns only the elements of list \<open>xs\<close> for which \<open>P xs = True\<close>.

  Hint: You do not necessarily need Isar, and the auxiliary lemmas
    you need are already in Isabelle's library. @{command find_theorems} is your friend!
\<close>

text \<open>\NumHomework{Quickselect}{May 25}

From \<^url>\<open>https://en.wikipedia.org/wiki/Quickselect\<close>:

Quickselect is a selection algorithm to find the kth smallest element in an unordered list.
It is related to the quicksort sorting algorithm.
Like quicksort, it was developed by Tony Hoare, and thus is also known as Hoare's selection
algorithm. Like quicksort, it is efficient in practice and has good average-case performance,
but has poor worst-case performance. Quickselect and its variants are the selection algorithms
most often used in efficient real-world implementations.

Quickselect uses the same overall approach as quicksort, choosing one element as a pivot and
partitioning the data in two based on the pivot, accordingly as less than or greater than the
pivot. However, instead of recursing into both sides, as in quicksort, quickselect only
recurses into one side --- the side with the element it is searching for.

Your task is to prove correct the quickselect algorithm, which can be
  implemented in Isabelle as follows:
\<close>

fun quickselect :: "'a::linorder list \<Rightarrow> nat \<Rightarrow> 'a" where
  "quickselect (x#xs) k = (let
    xs1 = [y\<leftarrow>xs. y<x];
    xs2 = [y\<leftarrow>xs. \<not>(y<x)]
  in
    if k<length xs1 then quickselect xs1 k
    else if k=length xs1 then x
    else quickselect xs2 (k-length xs1-1)
  )"
| "quickselect [] _ = undefined"

text \<open>Your first task is to prove the crucial idea of quicksort, i.e., that
  partitioning wrt.\ a pivot element $p$ is correct.
\<close>

lemma partition_correct: "sort xs = sort [x\<leftarrow>xs. x<p] @ sort [x\<leftarrow>xs. \<not>(x<p)]"
  oops

text \<open>
  Hint: Induction, and auxiliary lemmas to transform a term of the
    form @{term \<open>insort x (xs@ys)\<close>} when you know that \<open>x\<close> is greater than
    all elements in \<open>xs\<close> / less than or equal all elements in \<open>ys\<close>.
\<close>

text \<open>Next, show that quickselect is correct\<close>
lemma "k<length xs \<Longrightarrow> quickselect xs k = sort xs ! k"
  text \<open>Proceed by computation induction, and a case distinction according to the
    cases in the body of the quickselect function\<close>
proof (induction xs k rule: quickselect.induct)
  case (1 x xs k)

  text \<open>Note: To make the induction hypothesis more readable,
    you can collapse the first two premises of the form \<open>?x=\<dots>\<close>
    by reflexivity:\<close>
  note IH = "1.IH"[OF refl refl]

  text \<open>Insert your proof here!\<close>

  show ?case sorry
next
  case 2 then show ?case by simp
qed

(*<*)
end
(*>*)


theory Sorting
imports Main
        Naturals
        Listing
begin

fun sorted :: "nat List \<Rightarrow> bool" where
  "sorted Nil                   = True"
| "sorted (Cons _ Nil)          = True"
| "sorted (Cons r (Cons t ts))  = ( r \<le> 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 r \<le> 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) = (qsort [r <- ts. r \<le> t]) @ [t] @ (qsort [r <- ts. \<not> (r \<le> t)])"

fun sorted2 :: "nat list \<Rightarrow> bool" where
  "sorted2 []                   = True"
| "sorted2 [x]         = True"
| "sorted2 (r # (t # ts))  = (r \<le> t \<and> sorted2 (t # ts))"

fun merge :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
  "merge rs [] = rs"
| "merge [] ts = ts"
| "merge (r#rs) (t#ts) = (if r \<le> t then r # merge rs (t#ts)
                                       else t # merge (r#rs) ts)"

fun msort :: "nat list => nat list" where
  "msort [] = []"
| "msort [t] = [t]"
| "msort ts = merge (msort (List.take (length ts div 2) ts)) (* size instead? *)
                    (msort (List.drop (length ts div 2) ts))"

(* lemma sortCons: "r \<le> t \<and> sorted2 (t # ts) \<Longrightarrow> sorted2 (r # (t # ts))" by simp *)
lemma insSortInvar : "sorted ts \<Longrightarrow> sorted (insert t ts)"
by hipster_induct_schemes

lemma mer1[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge [] ts)"
(*by(metis sorted2.cases merge.simps)*) (* replace of cases by inductions *)
by hipster_induct_simp_metis

lemma mer2[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge [t] ts)" (* sorted2.induct! *)
by hipster_induct_schemes

lemma mer3[thy_expl]: "sorted2 ts \<Longrightarrow> sorted2 (merge ts [t])" (* sorted2.induct! *)
by hipster_induct_schemes

lemma mer4[thy_expl]: "sorted2 (t # ts) \<and> \<not> t \<le> r \<Longrightarrow> sorted2 (r # (merge (t#ts) []))" by simp

lemma mer4'[thy_expl]: "sorted2 (t # ts) \<and> t \<le> r \<Longrightarrow> sorted2 (t # merge ts [r])"
by (hipster_induct_schemes merge.simps mer3)

lemma mer5'[thy_expl]: "sorted2 (t # ts) \<and> r \<le> v \<and> \<not> t \<le> r \<Longrightarrow> sorted2 (r # (merge (t#ts) [v]))"
(*apply(induction ts rule: sorted2.induct)
apply(simp_all add: mer4 mer3 mer2 mer1)
apply(metis sorted2.simps merge.simps)*)
by (hipster_induct_schemes merge.simps mer3)

lemma mer5''[thy_expl]: "sorted2 (r # rs) \<and> \<not> t \<le> r \<Longrightarrow> sorted2 (r # (merge [t] rs))"
by (hipster_induct_schemes sorted2.simps)

lemma ssu[thy_expl]: "sorted2 (r # rs) \<and> t \<le> r \<Longrightarrow> sorted2 (t # (merge [] (r#rs)))" by (metis merge.simps sorted2.simps)
(*by (hipster_induct_simp_metis)*)

lemma ssu'[thy_expl]: "sorted2 (r # rs) \<and> t \<le> v \<and> t \<le> r \<Longrightarrow> sorted2 (t # (merge [v] (r#rs)))"
by (metis mer5'' merge.simps sorted2.simps)
lemma ssu''[thy_expl]: " sorted2 [t, v] \<and> sorted2 (r # rs) \<and> t \<le> r \<Longrightarrow> sorted2 (t # (merge [v] (r#rs)))"
(*by (metis sorted2.simps(3) ssu')*)
by (hipster_induct_schemes sorted2.simps mer5'')

lemma cons1[thy_expl]: "sorted2 (t # ts) \<Longrightarrow> sorted2 ts"
by hipster_induct_simp_metis
(*by (metis sorted2.elims(3) sorted2.simps(3))*)

lemma t1 : "sorted2 ts \<and> ts \<noteq> [] \<and> t \<le> hd ts \<Longrightarrow> sorted2 (t # ts)"
by hipster_induct_simp_metis
(*by (metis list.sel sorted2.elims(3))*)

lemma mer6[thy_expl]: "(sorted2 ts \<and> ts \<noteq> [] \<and> sorted2 (r # rs)) \<Longrightarrow> (sorted2 ((merge ts (r#rs))))"
apply(induction ts rule: sorted2.induct)
apply(induction rs rule: sorted2.induct)
apply(simp_all only: thy_expl)
apply(simp add: ssu'')
apply(rule conjI)
apply(rule impI)
apply(simp add: thy_expl)
apply(rule impI)
apply(rule conjI)
apply(simp add: thy_expl)
apply(simp add: thy_expl)
oops
(*by (hipster_induct_schemes ssu' ssu'' mer5' mer5'' mer3)
sledgehammer
apply(metis sorted2.simps ssu'' mer3 ssu ssu' mer4 mer2 mer1 t1 mer5' mer5'' mer4')*)

(* simplification can very much screw up the goal state! *)
lemma mer5[thy_expl]: "(sorted2 (t # ts) \<and> sorted2 (r # rs) \<and> t \<le> r) \<Longrightarrow> (sorted2 (t # (merge ts (r#rs))))"
apply(induction ts rule: sorted2.induct)
apply(simp)
apply(simp add: mer5'')
apply(simp add: mer4' mer5'' mer3 ssu' ssu'' ssu)
apply(rule conjI)
apply(rule impI)
apply simp
apply(rule impI, rule conjI)
apply(simp_all)
apply(drule conjE)
apply(simp_all add: ssu' mer5'' mer4 mer4' mer3 mer2 mer1 ssu'' mer5')
(*apply (metis (full_types) sorted2.simps merge.simps if_splits list.exhaust list.distinct)*)
(*apply(simp add: ssu ssu' mer3 mer2 mer1 ssu'' mer5' mer4')*)
(*apply(metis merge.simps(3) mer5' mer4' mer3 mer4)*)
sorry

lemma mergeS: "sorted2 ts \<and> sorted2 rs \<Longrightarrow> sorted2 (merge ts rs)"
apply(induction ts rs rule: merge.induct)
sledgehammer
apply (metis merge.simps(1))
sledgehammer
apply (metis merge.simps(2))
sledgehammer
sledgehammer min [e] (cons1 mer4 mer5 merge.elims merge.simps(1) merge.simps(3) nat_induct ord.lexordp_eq.simps ord.lexordp_eq_simps(3) qsort.cases sorted2.simps(3))
apply(simp_all add: mer1 mer2)
(*sledgehammer*)
by (metis mer4 mer5 merge.simps sorted2.simps)
(*
apply(cases rs)
apply(simp_all)
by (hipster_induct_schemes mer1 mer5'' mer5 merge.simps sorted2.simps)*)
(*apply(induction ts rule: sorted2.induct)
apply(simp add: mer1)
apply(simp add: mer5'')
by (metis mer4 mer5 merge.simps sorted2.simps)*)
(* apply(induction ts rule: sorted2.induct)
apply(simp add: mer1)
apply(simp add: mer2)
apply(cases rs)
apply(simp_all)
by (metis mer4 mer5 merge.simps sorted2.simps)*)
(*   by (induct xs ys rule: merge.induct) (auto simp add: ball_Un not_le less_le sorted_Cons) *)

lemma smsort: "sorted2 (msort xs)"
by (hipster_induct_schemes mergeS)

(*lemma merComm: "sorted2 ts \<and> sorted2 rs \<Longrightarrow> merge rs ts = merge ts rs"
apply(induction rs ts rule: merge.induct)
apply(simp_all)
apply(metis sorted2.cases merge.simps(1) merge.simps(2))*)

(*
fun merge :: "Nat list \<Rightarrow> Nat list \<Rightarrow> Nat list" where
  "merge [] ts = ts"
| "merge rs [] = rs"
| "merge (r#rs) (t#ts) = (if leq r t then (r # (merge rs (t # ts)) )
                                     else (t # (merge (r # rs) ts) ) )"

fun msort :: "Nat list \<Rightarrow> Nat list" where
  "msort [] = []"
| "msort [t] = [t]"
| "msort ts = merge (msort (take ((length ts) div 2) ts))
                    (msort (drop ((length ts) div 2) ts))*)
(* in a let ... *)

(* qsort *)

end


header {* Solutions to Chapter 7 of "Concrete Semantics" *}

theory Chap_seven imports Big_step Small_step begin

declare [[names_short]]

(* 7.1 *)

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}" |
"assigned (c1;;c2) = assigned c1 \<union> assigned c2" |
"assigned (x ::= a) = {x}" |
"assigned (IF b THEN c1 ELSE c2) = assigned c1 \<union> assigned c2" |
"assigned (WHILE b DO c) = assigned c"

lemma "\<lbrakk>(c, s) \<Rightarrow> t; x \<notin> assigned c\<rbrakk> \<Longrightarrow> s x = t x"
apply (induction rule: big_step_induct)
apply (auto)
done

(* 7.2 *)

fun skip :: "com \<Rightarrow> bool" where
"skip SKIP = True" |
"skip (c1;;c2) = (skip c1 \<and> skip c2)" |
"skip (x::=a) = False" |
"skip (IF b THEN c1 ELSE c2) = (skip c1 \<and> skip c2)" |
"skip (WHILE b DO c) = False"

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
proof (induction c)
  case (Seq c1 c2)
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" by auto
  hence "(c1;;c2) \<sim> (SKIP;;SKIP)" by blast
  thus "(c1;;c2) \<sim> SKIP" by blast
next
  case (If b c1 c2)
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" by auto
  thus "IF b THEN c1 ELSE c2 \<sim> SKIP" by blast
qed auto+

(* 7.3 *)

fun deskip :: "com \<Rightarrow> com" where
"deskip (c1;;c2) = (case (deskip c1, deskip c2) of
 (SKIP, SKIP) \<Rightarrow> SKIP |
 (SKIP, q) \<Rightarrow> q |
 (p, SKIP) \<Rightarrow> p |
 (p, q) \<Rightarrow> (p;;q))" |
"deskip (WHILE b DO c) = WHILE b DO (deskip c)" |
"deskip (IF b THEN c1 ELSE c2) = IF b THEN (deskip c1) ELSE (deskip c2)" |
"deskip c = c"

lemma "deskip c \<sim> c"
proof (induction c)
 case (Seq c1 c2)
 hence "c1;; c2 \<sim> (deskip c1);; (deskip c2)" by auto
 moreover have "(deskip c1);; (deskip c2) \<sim> deskip (c1;; c2)"
  by (auto split: com.split)
 ultimately show ?case by auto
qed (auto simp add: sim_while_cong)+

(* 7.4 *)

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x , s) \<leadsto> N (s x)" |
"(Plus (N i) (N j), s) \<leadsto> N (i + j)"  |
"(p, s) \<leadsto> (N p') \<Longrightarrow> (Plus (N p') q, s) \<leadsto> r \<Longrightarrow> (Plus p q, s) \<leadsto> r" |
"(q, s) \<leadsto> (N q') \<Longrightarrow> (Plus (N i) q, s) \<leadsto> N (i + q')"

code_pred astep .

values "{c' |c'.
   (Plus (Plus (V ''x'') (V ''z'')) (V ''y''),
    <''x'' := 1, ''y'' := 7, ''z'' := 15>) \<leadsto> c'}"

lemmas astep_induct = astep.induct[split_format(complete)]

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
 by (induction rule: astep_induct, auto)

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep_induct)
 fix x s
 show "aval (V x) s = aval (N (s x)) s" by simp
next
 fix i j s
 show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by simp
next
 fix p s p' q r
 assume a: "(p, s) \<leadsto> N p'"
 assume b: "aval p s = aval (N p') s"
 assume c: "(Plus (N p') q, s) \<leadsto> r"
 assume d: "aval (Plus (N p') q) s = aval r s"
 show "aval (Plus p q) s = aval r s" using a b c d by simp
next
 fix q s q' i
 assume a: "(q, s) \<leadsto> N q'"
 assume b: "aval q s = aval (N q') s"
 show "aval (Plus (N i) q) s = aval (N (i + q')) s" using a b by simp
qed

(* 7.5 *)

lemma "IF And b1 b2 THEN c1 ELSE c2 \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2" (is "?P \<sim> ?Q")
proof -
  { fix s t
    assume "(?P, s) \<Rightarrow> t"
    { assume b: "(bval b1 s) \<and> (bval b2 s)"
      with `(?P, s) \<Rightarrow> t` have "(c1, s) \<Rightarrow> t" by auto
      hence "(?Q, s) \<Rightarrow> t" using b by auto
    }
    moreover
    { assume b: "\<not> ((bval b1 s) \<and> (bval b2 s))"
      hence "\<not> bval (And b1 b2) s" by auto
      with `(?P, s) \<Rightarrow> t` have "(c2, s) \<Rightarrow> t" by auto
      hence "(?Q, s) \<Rightarrow> t" using b by auto
    }
    ultimately have "(?Q, s) \<Rightarrow> t" by auto
  }
  moreover
  { fix s t
    assume "(?Q, s) \<Rightarrow> t"
    { assume b: "(bval b1 s) \<and> (bval b2 s)"
      with `(?Q, s) \<Rightarrow> t` have "(c1, s) \<Rightarrow> t" by auto
      hence "(?P, s) \<Rightarrow> t" using b by auto
    }
    moreover
    { assume b: "\<not> ((bval b1 s) \<and> (bval b2 s))"
      with `(?Q, s) \<Rightarrow> t` have "(c2, s) \<Rightarrow> t" by auto
      from b have "\<not> bval (And b1 b2) s" by auto
      hence "(?P, s) \<Rightarrow> t" using `(c2, s) \<Rightarrow> t` by auto
    }
    ultimately have "(?P, s) \<Rightarrow> t" by auto
  }
  ultimately show ?thesis by auto
qed

lemma "\<not> (\<forall> b1 b2 c. WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c)" (is "\<not> ?P")
proof
  assume "?P"
  then obtain l p t where
   vars:
    "l = Bc True"
    "t = Bc False"
    "p = SKIP"
   and "bval (And l t) s = False"
   and a: "WHILE And l t DO p \<sim> WHILE l DO WHILE t DO p" by auto
   then have "(WHILE And l t DO p, s) \<Rightarrow> s" by blast
   with a have "(WHILE l DO WHILE t DO p, s) \<Rightarrow> s" by auto
   thus False
    by (induction "WHILE l DO WHILE t DO p" s s rule: big_step_induct, auto simp add: vars)
qed

abbreviation Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
 "Or b1 b2 \<equiv> Not (And (Not b1) (Not b2))"

lemma "WHILE Or b1 b2 DO c \<sim> WHILE Or b1 b2 DO c;; WHILE b1 DO c" (is "?P \<sim> ?P ;; ?Q")
proof -
  { fix b c' s t have "(WHILE b DO c', s) \<Rightarrow> t \<Longrightarrow> \<not> bval b t"
    by (induction "WHILE b DO c'" s t rule: big_step_induct)
  } note while_false = this

  { fix s t assume a: "(?P, s) \<Rightarrow> t"
    with while_false have "\<not> bval (Or b1 b2) t" by blast
    hence "(?Q, t) \<Rightarrow> t" by auto
    with a have "(?P ;; ?Q, s) \<Rightarrow> t" by auto
  }
  moreover
  { fix s t assume a: "(?P ;; ?Q, s) \<Rightarrow> t"
    then obtain s' where a1: "(?P, s) \<Rightarrow> s'" and a2: "(?Q, s') \<Rightarrow> t" by auto
    with while_false have "\<not> bval (Or b1 b2) s'" by blast
    hence "(?Q, s') \<Rightarrow> s'" by auto
    with a2 big_step_determ have "s' = t" by auto
    with a1 have "(?P, s) \<Rightarrow> t" by auto
  }
  ultimately show ?thesis by blast
qed

(* 7.6 *)

abbreviation DoWhile :: "com \<Rightarrow> bexp \<Rightarrow> com" ("(DO _/ WHILE _)"  [0, 61] 61) where
"DO c WHILE b \<equiv> (c ;; WHILE b DO c)"

fun dewhile :: "com \<Rightarrow> com" where
"dewhile (WHILE b DO c) = IF b THEN DO (dewhile c) WHILE b ELSE SKIP" |
"dewhile (c1;; c2) = (dewhile c1);; dewhile c2" |
"dewhile (IF b THEN c1 ELSE c2) = (IF b THEN (dewhile c1) ELSE (dewhile c2))" |
"dewhile c = c"

lemma "dewhile c \<sim> c"
proof (induction c)
  case (While b c)
  hence "WHILE b DO c \<sim> WHILE b DO dewhile c" using sim_while_cong by auto
  moreover have
   "WHILE b DO dewhile c \<sim> IF b THEN DO (dewhile c) WHILE b ELSE SKIP" using while_unfold by auto
  ultimately have
   "WHILE b DO c \<sim> IF b THEN DO (dewhile c) WHILE b ELSE SKIP" using sim_trans by blast
  thus ?case by auto
qed auto+

(* 7.7 *)

lemma
 fixes
  C :: "nat \<Rightarrow> com" and
  S :: "nat \<Rightarrow> state"
 assumes
  "C 0 = c;; d"
  "\<forall> n. (C n, S n) \<rightarrow> (C (Suc n), S (Suc n))"
 shows
 "(\<forall> n. \<exists> c1 c2.
   C n = c1;; d \<and>
   C (Suc n) = c2;; d \<and>
   (c1, S n) \<rightarrow> (c2, S (Suc n))) \<or>
 (\<exists> k. C k = SKIP;; d)" (is "?P \<or> ?Q")
proof cases
  assume "?Q"
  thus ?thesis by auto
next
  assume "\<not> ?Q"
  { fix n c1 assume cn: "C n = c1;; d"
    hence "\<exists> c2. C (Suc n) = c2;; d \<and> (c1, S n) \<rightarrow> (c2, S (Suc n))"
    proof -
      from assms have "(C n, S n) \<rightarrow> (C (Suc n), S (Suc n))" by blast
      with cn have cc: "(c1;; d, S n) \<rightarrow> (C (Suc n), S (Suc n))" by auto
      then obtain c2 where "C (Suc n) = c2;; d"
        "(c1, S n) \<rightarrow> (c2, S (Suc n))" using  `\<not> ?Q` cn by blast
      then show ?thesis by auto
    qed
  } note Cn_induction = this

  { fix n
    have "\<exists>c1 c2. C n = c1;; d \<and> C (Suc n) = c2;; d \<and> (c1, S n) \<rightarrow> (c2, S (Suc n))"
    proof (induction n)
      case 0
      from assms obtain c1 where c1: "C 0 = c1;; d" by auto
      with Cn_induction obtain c2  where "C (Suc 0) = c2;; d"
        "(c1, S 0) \<rightarrow> (c2, S (Suc 0))" by blast
      with c1 show ?case by auto
    next
      case (Suc n)
      from this obtain c1 where c1: "C (Suc n) = c1;; d" by blast
      with Cn_induction obtain c2 where "C (Suc (Suc n)) = c2;; d"
        "(c1, S (Suc n)) \<rightarrow> (c2, S (Suc (Suc n)))" by blast
      with c1 show ?case by auto
    qed
  }
  thus ?thesis by auto
qed


section \<open>Preliminaries\<close>
theory Preliminaries
  imports
    Main
    HOL.Real
    "HOL-Library.FuncSet"
begin

lemma fact_approx_add: "fact (l + n) \<le> fact l * (real l + real n) ^ n"
proof (induct n arbitrary: l)
  case (Suc n l)
  have "fact (l + Suc n) = (real l + Suc n) * fact (l + n)" by simp
  also have "\<dots> \<le> (real l + Suc n) * (fact l * (real l + real n) ^ n)"
    by (intro mult_left_mono[OF Suc], auto)
  also have "\<dots> = fact l * ((real l + Suc n) * (real l + real n) ^ n)" by simp
  also have "\<dots> \<le> fact l * ((real l + Suc n) * (real l + real (Suc n)) ^ n)"
    by (rule mult_left_mono, rule mult_left_mono, rule power_mono, auto)
  finally show ?case by simp
qed simp

lemma fact_approx_minus: assumes "k \<ge> n"
  shows "fact k \<le> fact (k - n) * (real k ^ n)"
proof -
  define l where "l = k - n"
  from assms have k: "k = l + n" unfolding l_def by auto
  show ?thesis unfolding k using fact_approx_add[of l n] by simp
qed

lemma fact_approx_upper_add: assumes al: "a \<le> Suc l" shows "fact l * real a ^ n \<le> fact (l + n)"
proof (induct n)
  case (Suc n)
  have "fact l * real a ^ (Suc n) = (fact l * real a ^ n) * real a" by simp
  also have "\<dots> \<le> fact (l + n) * real a"
    by (rule mult_right_mono[OF Suc], auto)
  also have "\<dots> \<le> fact (l + n) * real (Suc (l + n))"
    by (intro mult_left_mono, insert al, auto)
  also have "\<dots> = fact (Suc (l + n))" by simp
  finally show ?case by simp
qed simp

lemma fact_approx_upper_minus: assumes "n \<le> k" and "n + a \<le> Suc k"
  shows "fact (k - n) * real a ^ n \<le> fact k"
proof -
  define l where "l = k - n"
  from assms have k: "k = l + n" unfolding l_def by auto
  show ?thesis using assms unfolding k
    apply simp
    apply (rule fact_approx_upper_add, insert assms, auto simp: l_def)
    done
qed

lemma choose_mono: "n \<le> m \<Longrightarrow> n choose k \<le> m choose k"
  unfolding binomial_def
  by (rule card_mono, auto)

lemma div_mult_le: "(a div b) * c \<le> (a * c) div (b :: nat)"
  by (metis div_mult2_eq div_mult_mult2 mult.commute mult_0_right times_div_less_eq_dividend)

lemma div_mult_pow_le: "(a div b)^n \<le> a^n div (b :: nat)^n"
proof (cases "b = 0")
  case True
  thus ?thesis by (cases n, auto)
next
  case b: False
  then obtain c d where a: "a = b * c + d" and id: "c = a div b" "d = a mod b" by auto
  have "(a div b)^n = c^n" unfolding id by simp
  also have "\<dots> = (b * c)^n div b^n" using b
    by (metis div_power dvd_triv_left nonzero_mult_div_cancel_left)
  also have "\<dots> \<le> (b * c + d)^n div b^n"
    by (rule div_le_mono, rule power_mono, auto)
  also have "\<dots> = a^n div b^n " unfolding a by simp
  finally show ?thesis .
qed

lemma choose_inj_right:
  assumes id: "(n choose l) = (k choose l)"
    and n0: "n choose l \<noteq> 0"
    and l0:  "l \<noteq> 0"
  shows "n = k"
proof (rule ccontr)
  assume nk: "n \<noteq> k"
  define m where "m = min n k"
  define M where "M = max n k"
  from nk have mM: "m < M" unfolding m_def M_def by auto
  let ?new = "insert (M - 1) {0..< l - 1}"
  let ?m = "{K \<in> Pow {0..<m}. card K = l}"
  let ?M = "{K \<in> Pow {0..<M}. card K = l}"
  from id n0 have lM :"l \<le> M" unfolding m_def M_def by auto
  from id have id: "(m choose l) = (M choose l)"
    unfolding m_def M_def by auto
  from this[unfolded binomial_def]
  have "card ?M < Suc (card ?m)"
    by auto
  also have "\<dots> = card (insert ?new ?m)"
    by (rule sym, rule card_insert_disjoint, force, insert mM, auto)
  also have "\<dots> \<le> card (insert ?new ?M)"
    by (rule card_mono, insert mM, auto)
  also have "insert ?new ?M = ?M"
    by (insert mM lM l0, auto)
  finally show False by simp
qed

end


section \<open>Connection of Euler--MacLaurin summation to Landau symbols\<close>
theory Euler_MacLaurin_Landau
imports
  Euler_MacLaurin
  Landau_Symbols.Landau_More
begin

subsection \<open>$O$-bound for the remainder term\<close>

text \<open>
  Landau symbols allow us to state the bounds on the remainder terms
  from the Euler--MacLaurin formula a bit more nicely.
\<close>

lemma
  fixes f :: "real \<Rightarrow> 'a :: {real_normed_field, banach}"
    and g g' :: "real \<Rightarrow> real"
  assumes fin:     "finite Y"
  assumes cont_f:  "continuous_on {a..} f"
  assumes cont_g:  "continuous_on {a..} g"
  assumes cont_g': "continuous_on {a..} g'"
  assumes limit_g: "(g \<longlongrightarrow> 0) at_top"
  assumes f_bound: "\<And>x. x \<ge> a \<Longrightarrow> norm (f x) \<le> g' x"
  assumes deriv:   "\<And>x. x \<in> {a..} - Y \<Longrightarrow> (g has_field_derivative -g' x) (at x)"
  shows   EM_remainder_strong_bigo_int: "(\<lambda>x::int. norm (EM_remainder n f x)) \<in> O(g)"
    and   EM_remainder_strong_bigo_nat: "(\<lambda>x::nat. norm (EM_remainder n f x)) \<in> O(g)"
proof -
  from bounded_pbernpoly[of n] obtain D where D: "\<forall>x. \<bar>pbernpoly n x\<bar> \<le> D" by auto
  from norm_EM_remainder_le_strong_int'[OF fin D assms(2-)]
    have *: "\<And>x. x \<ge> a \<longrightarrow> norm (EM_remainder n f x) \<le> D / fact n * g x" by auto
  have **: "eventually (\<lambda>x::int. norm (EM_remainder n f x) \<le> abs (D / fact n) * abs (g x)) at_top"
    using eventually_ge_at_top[of "ceiling a"]
  proof eventually_elim
    case (elim x)
    with *[of x] have "norm (EM_remainder n f x) \<le> D / fact n * g x" by (simp add: ceiling_le_iff)
    also have "\<dots> \<le> abs (D / fact n * g x)" by (rule abs_ge_self)
    also have "\<dots> = abs (D / fact n) * abs (g x)" by (simp add: abs_mult)
    finally show ?case .
  qed
  thus "(\<lambda>x::int. norm (EM_remainder n f x)) \<in> O(g)"
    by (intro bigoI[of _ "abs D / fact n"]) (auto elim!: eventually_mono)
  hence "(\<lambda>x::nat. norm (EM_remainder n f (int x))) \<in> O(\<lambda>x. g (of_int (int x)))"
    by (rule landau_o.big.compose) (fact filterlim_int_sequentially)
  thus "(\<lambda>x::nat. norm (EM_remainder n f x)) \<in> O(g)" by simp
qed

subsection \<open>Asymptotic expansion of the harmonic numbers\<close>

text \<open>
  We can now show the asymptotic expansion
  \[H_n = \ln n + \gamma + \frac{1}{2n} - \sum_{i=1}^m \frac{B_{2i}}{2i} n^{-2i} + O(n^{-2m-2})\]
\<close>

lemma harm_remainder_bigo:
  assumes "N > 0"
  shows   "harm_remainder N \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 1))"
proof -
  from harm_remainder_bound[OF assms] guess C ..
  thus ?thesis
    by (intro bigoI[of _ C] eventually_mono[OF eventually_ge_at_top[of 1]]) auto
qed

lemma harm_expansion_bigo:
  fixes N :: nat
  defines "T \<equiv> \<lambda>n. ln n + euler_mascheroni + 1 / (2*n) -
                     (\<Sum>i=1..N. bernoulli (2*i) / ((2*i) * n ^ (2*i)))"
  defines "S \<equiv> (\<lambda>n. bernoulli (2*(Suc N)) / ((2*Suc N) * real n ^ (2*Suc N)))"
  shows "(\<lambda>n. harm n - T n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
proof -
  have "(\<lambda>n. harm n - T n) \<in> \<Theta>(\<lambda>n. -S n - harm_remainder (Suc N) n)"
    by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: T_def harm_expansion[of _ "Suc N"] S_def)
  also have "(\<lambda>n. -S n - harm_remainder (Suc N) n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
  proof (intro sum_in_bigo)
    show "(\<lambda>x. - S x) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))" unfolding S_def
      by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
    have "harm_remainder (Suc N) \<in> O(\<lambda>n. 1 / real n ^ (2 * Suc N + 1))"
      by (rule harm_remainder_bigo) simp_all
    also have "(\<lambda>n. 1 / real n ^ (2 * Suc N + 1)) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
      by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
    finally show "harm_remainder (Suc N) \<in> \<dots>" .
  qed
  finally show ?thesis .
qed

lemma harm_expansion_bigo_simple2:
  "(\<lambda>n. harm n - (ln n + euler_mascheroni)) \<in> O(\<lambda>n. 1 / n)"
proof -
  have "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n)) + 1 / (2 * n)) \<in> O(\<lambda>n. 1 / n)"
  proof (rule sum_in_bigo)
    have "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n))) \<in> O(\<lambda>n. 1 / real n ^ 2)"
      using harm_expansion_bigo_simple1 by simp
    also have "(\<lambda>n. 1 / real n ^ 2) \<in> O(\<lambda>n. 1 / real n)"
      by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp_all
    finally show "(\<lambda>n. harm n - (ln n + euler_mascheroni + 1 / (2 * n))) \<in> O(\<lambda>n. 1 / n)" by simp
  qed simp_all
  thus ?thesis by (simp add: algebra_simps)
qed

lemma harm_expansion_bigo_simple':
  "harm =o (\<lambda>n. ln n + euler_mascheroni + 1 / (2 * n)) +o O(\<lambda>n. 1 / n ^ 2)"
  using harm_expansion_bigo_simple1
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

subsection \<open>Asymptotic expansion of the sum of inverse squares\<close>

text \<open>
  Similarly to before, we show
  \[\sum_{i=1}^n \frac{1}{i^2} = \frac{\pi^2}{6} - \frac{1}{n} + \frac{1}{2n^2} -
     \sum_{i=1}^m B_{2i} n^{-2i-1} + O(n^{-2m-3})\]
\<close>

context
  fixes R :: "nat \<Rightarrow> nat \<Rightarrow> real"
  defines "R \<equiv> (\<lambda>N n. EM_remainder (2*N+1) (\<lambda>x. -fact (2*N+2) / x ^ (2*N+3)) (int n))"
begin

lemma sum_inverse_squares_remainder_bigo:
  assumes "N > 0"
  shows   "R N \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 2))"
proof -
  from sum_inverse_squares_remainder_bound[OF assms] guess C ..
  thus ?thesis
    by (intro bigoI[of _ C] eventually_mono[OF eventually_ge_at_top[of 1]]) (auto simp: R_def)
qed

lemma sum_inverse_squares_expansion_bigo:
  fixes N :: nat
  defines "T \<equiv> \<lambda>n. pi ^ 2 / 6 - 1 / n + 1 / (2*n ^ 2) -
                     (\<Sum>i=1..N. bernoulli (2*i) / (n ^ (2*i+1)))"
  defines "S \<equiv> (\<lambda>n. bernoulli (2*(Suc N)) / (real n ^ (2*N+3)))"
  shows "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - T n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
proof -
  have 3: "3 = Suc (Suc (Suc 0))" by simp
  have "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - T n) \<in> \<Theta>(\<lambda>n. -S n - R (Suc N) n)" unfolding R_def
    by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: T_def sum_inverse_squares_expansion[of _ "Suc N"] S_def 3
             simp del: One_nat_def)
  also have "(\<lambda>n. -S n - R (Suc N) n) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
  proof (intro sum_in_bigo)
    show "(\<lambda>x. - S x) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))" unfolding S_def
      by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
    have "R (Suc N) \<in> O(\<lambda>n. 1 / real n ^ (2 * Suc N + 2))"
      by (rule sum_inverse_squares_remainder_bigo) simp_all
    also have "2 * Suc N + 2 = 2 * N + 4" by simp
    also have "(\<lambda>n. 1 / real n ^ (2 * N + 4)) \<in> O(\<lambda>n. 1 / real n ^ (2 * N + 3))"
      by (rule landau_o.big.compose[OF _ filterlim_real_sequentially]) simp
    finally show "R (Suc N) \<in> \<dots>" .
  qed
  finally show ?thesis .
qed

lemma sum_inverse_squares_expansion_bigo_simple:
  "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2) - (pi ^ 2 / 6 - 1 / n + 1 / (2*n^2))) \<in> O(\<lambda>n. 1 / n ^ 3)"
  using sum_inverse_squares_expansion_bigo[of 0] by (simp add: power2_eq_square)

lemma sum_inverse_squares_expansion_bigo_simple':
  "(\<lambda>n. (\<Sum>i=1..n. 1 / real i ^ 2)) =o (\<lambda>n. pi ^ 2 / 6 - 1 / n + 1 / (2*n^2)) +o O(\<lambda>n. 1 / n^3)"
  using sum_inverse_squares_expansion_bigo_simple
  by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def)

end

end


theory InsertSort
imports
  Complex_Main
  "HOL-Library.Multiset"
begin

context linorder
begin

fun insort :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort x [] = [x]" |
"insort x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort x ys))"

fun isort :: "'a list \<Rightarrow> 'a list" where
"isort [] = []" |
"isort (x#xs) = insort x (isort xs)"

value "isort [100,39,2::nat, 3,5,10,300]"
subsubsection "Functional Correctness"

lemma mset_insort: "mset (insort x xs) = add_mset x (mset xs)"
apply(induction xs)
apply auto
done

lemma mset_isort: "mset (isort xs) = mset xs"
apply(induction xs)
apply simp
apply (simp add: mset_insort)
done

lemma insort_set: "set (insort x xs) = insert x (set xs)"
  apply(induct xs) by auto

lemma sorted_insort: "sorted (insort a xs) = sorted xs"
apply(induction xs) apply simp
apply(case_tac "a \<le> aa")
  apply auto[1]
  apply simp
  apply(rule iffI)
    apply (simp add: insort_set)
    apply (simp add: insort_set)
done

lemma sorted_isort: "sorted (isort xs)"
apply(induction xs)
apply(auto simp: sorted_insort)
done
end

end


(*  Title:      HOL/Hahn_Banach/Normed_Space.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Normed vector spaces\<close>

theory Normed_Space
imports Subspace
begin

subsection \<open>Quasinorms\<close>

text \<open>
  A \emph{seminorm} @{text "\<parallel>\<cdot>\<parallel>"} is a function on a real vector space
  into the reals that has the following properties: it is positive
  definite, absolute homogeneous and subadditive.
\<close>

locale seminorm =
  fixes V :: "'a\<Colon>{minus, plus, zero, uminus} set"
  fixes norm :: "'a \<Rightarrow> real"    ("\<parallel>_\<parallel>")
  assumes ge_zero [iff?]: "x \<in> V \<Longrightarrow> 0 \<le> \<parallel>x\<parallel>"
    and abs_homogenous [iff?]: "x \<in> V \<Longrightarrow> \<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>"
    and subadditive [iff?]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"

declare seminorm.intro [intro?]

lemma (in seminorm) diff_subadditive:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x - y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V" and y: "y \<in> V"
  then have "x - y = x + - 1 \<cdot> y"
    by (simp add: diff_eq2 negate_eq2a)
  also from x y have "\<parallel>\<dots>\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>- 1 \<cdot> y\<parallel>"
    by (simp add: subadditive)
  also from y have "\<parallel>- 1 \<cdot> y\<parallel> = \<bar>- 1\<bar> * \<parallel>y\<parallel>"
    by (rule abs_homogenous)
  also have "\<dots> = \<parallel>y\<parallel>" by simp
  finally show ?thesis .
qed

lemma (in seminorm) minus:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> \<parallel>- x\<parallel> = \<parallel>x\<parallel>"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V"
  then have "- x = - 1 \<cdot> x" by (simp only: negate_eq1)
  also from x have "\<parallel>\<dots>\<parallel> = \<bar>- 1\<bar> * \<parallel>x\<parallel>" by (rule abs_homogenous)
  also have "\<dots> = \<parallel>x\<parallel>" by simp
  finally show ?thesis .
qed

subsection \<open>Norms\<close>

text \<open>
  A \emph{norm} @{text "\<parallel>\<cdot>\<parallel>"} is a seminorm that maps only the
  @{text 0} vector to @{text 0}.
\<close>

locale norm = seminorm +
  assumes zero_iff [iff]: "x \<in> V \<Longrightarrow> (\<parallel>x\<parallel> = 0) = (x = 0)"

subsection \<open>Normed vector spaces\<close>

text \<open>
  A vector space together with a norm is called a \emph{normed
  space}.
\<close>

locale normed_vectorspace = vectorspace + norm

declare normed_vectorspace.intro [intro?]

lemma (in normed_vectorspace) gt_zero [intro?]:
  assumes x: "x \<in> V" and neq: "x \<noteq> 0"
  shows "0 < \<parallel>x\<parallel>"
proof -
  from x have "0 \<le> \<parallel>x\<parallel>" ..
  also have "0 \<noteq> \<parallel>x\<parallel>"
  proof
    assume "0 = \<parallel>x\<parallel>"
    with x have "x = 0" by simp
    with neq show False by contradiction
  qed
  finally show ?thesis .
qed

text \<open>
  Any subspace of a normed vector space is again a normed vectorspace.
\<close>

lemma subspace_normed_vs [intro?]:
  fixes F E norm
  assumes "subspace F E" "normed_vectorspace E norm"
  shows "normed_vectorspace F norm"
proof -
  interpret subspace F E by fact
  interpret normed_vectorspace E norm by fact
  show ?thesis
  proof
    show "vectorspace F" by (rule vectorspace) unfold_locales
  next
    have "Normed_Space.norm E norm" ..
    with subset show "Normed_Space.norm F norm"
      by (simp add: norm_def seminorm_def norm_axioms_def)
  qed
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_33
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun min :: "Nat => Nat => Nat" where
  "min (Z) z = Z"
| "min (S z2) (Z) = Z"
| "min (S z2) (S y1) = S (min z2 y1)"

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

theorem property0 :(* A bit similar to TIP_prop_24.thy *)
  "((x (min a b) a) = (t2 a b))"
  find_proof DInd
  apply (induct rule: TIP_prop_33.x.induct)
     apply auto
  done
    (*Why does "x.induct" lead to the shortest proof?
  Because "x"'s pattern-matching is complete, meaning that it does not involve any wild-card.*)

end


(*
  File:   Prime_Harmonic.thy
  Author: Manuel Eberl <manuel@pruvisto.org>

  A lower bound for the partial sums of the prime harmonic series, and a proof of its divergence.
  (#81 on the list of 100 mathematical theorems)
*)

section \<open>The Prime Harmonic Series\<close>
theory Prime_Harmonic
imports
  "HOL-Analysis.Analysis"
  "HOL-Number_Theory.Number_Theory"
  Prime_Harmonic_Misc
  Squarefree_Nat
begin

subsection \<open>Auxiliary equalities and inequalities\<close>

text \<open>
  First of all, we prove the following result about rearranging a product over a set into a sum
  over all subsets of that set.
\<close>
lemma prime_harmonic_aux1:
  fixes A :: "'a :: field set"
  shows "finite A \<Longrightarrow> (\<Prod>x\<in>A. 1 + 1 / x) = (\<Sum>x\<in>Pow A. 1 / \<Prod>x)"
proof (induction rule: finite_induct)
  fix a :: 'a and A :: "'a set"
  assume a: "a \<notin> A" and fin: "finite A"
  assume IH: "(\<Prod>x\<in>A. 1 + 1 / x) = (\<Sum>x\<in>Pow A. 1 / \<Prod>x)"
  from a and fin have "(\<Prod>x\<in>insert a A. 1 + 1 / x) = (1 + 1 / a) * (\<Prod>x\<in>A. 1 + 1 / x)" by simp
  also from fin have "\<dots> = (\<Sum>x\<in>Pow A. 1 / \<Prod>x) + (\<Sum>x\<in>Pow A. 1 / (a * \<Prod>x))"
    by (subst IH) (auto simp add: algebra_simps sum_divide_distrib)
  also from fin a have "(\<Sum>x\<in>Pow A. 1 / (a * \<Prod>x)) = (\<Sum>x\<in>Pow A. 1 / \<Prod>(insert a x))"
    by (intro sum.cong refl, subst prod.insert) (auto dest: finite_subset)
  also from a have "\<dots> = (\<Sum>x\<in>insert a ` Pow A. 1 / \<Prod>x)"
    by (subst sum.reindex) (auto simp: inj_on_def)
  also from fin a have "(\<Sum>x\<in>Pow A. 1 / \<Prod>x) + \<dots> = (\<Sum>x\<in>Pow A \<union> insert a ` Pow A. 1 / \<Prod>x)"
    by (intro sum.union_disjoint [symmetric]) (simp, simp, blast)
  also have "Pow A \<union> insert a ` Pow A = Pow (insert a A)" by (simp only: Pow_insert)
  finally show " (\<Prod>x\<in>insert a A. 1 + 1 / x) = (\<Sum>x\<in>Pow (insert a A). 1 / \<Prod>x)" .
qed simp

text \<open>
  Next, we prove a simple and reasonably accurate upper bound for the sum of the squares of any
  subset of the natural numbers, derived by simple telescoping. Our upper bound is approximately
  1.67; the exact value is $\frac{\pi^2}{6} \approx 1.64$. (cf. Basel problem)
\<close>
lemma prime_harmonic_aux2:
  assumes "finite (A :: nat set)"
  shows   "(\<Sum>k\<in>A. 1 / (real k ^ 2)) \<le> 5/3"
proof -
  define n where "n = max 2 (Max A)"
  have n: "n \<ge> Max A" "n \<ge> 2" by (auto simp: n_def)
  with assms have "A \<subseteq> {0..n}" by (auto intro: order.trans[OF Max_ge])
  hence "(\<Sum>k\<in>A. 1 / (real k ^ 2)) \<le> (\<Sum>k=0..n. 1 / (real k ^ 2))" by (intro sum_mono2) auto
  also from n have "\<dots> = 1 + (\<Sum>k=Suc 1..n. 1 / (real k ^ 2))" by (simp add: sum.atLeast_Suc_atMost)
  also have "(\<Sum>k=Suc 1..n. 1 / (real k ^ 2)) \<le>
          (\<Sum>k=Suc 1..n. 1 / (real k ^ 2 - 1/4))" unfolding power2_eq_square
    by (intro sum_mono divide_left_mono mult_pos_pos)
       (linarith, simp_all add: field_simps less_1_mult)
  also have "\<dots> = (\<Sum>k=Suc 1..n. 1 / (real k - 1/2) - 1 / (real (Suc k) - 1/2))"
    by (intro sum.cong refl) (simp_all add: field_simps power2_eq_square)
  also from n have "\<dots> = 2 / 3 - 1 / (1 / 2 + real n)"
    by (subst sum_telescope') simp_all
  also have "1 + \<dots> \<le> 5/3" by simp
  finally show ?thesis by - simp
qed

subsection \<open>Estimating the partial sums of the Prime Harmonic Series\<close>

text \<open>
  We are now ready to show our main result: the value of the partial prime harmonic sum over
  all primes no greater than $n$ is bounded from below by the $n$-th harmonic number
  $H_n$ minus some constant.

  In our case, this constant will be $\frac{5}{3}$. As mentioned before, using a
  proof of the Basel problem can improve this to $\frac{\pi^2}{6}$, but the improvement is very
  small and the proof of the Basel problem is a very complex one.

  The exact asymptotic behaviour of the partial sums is actually $\ln (\ln n) + M$, where $M$
  is the Meissel--Mertens constant (approximately 0.261).
\<close>
theorem prime_harmonic_lower:
  assumes n: "n \<ge> 2"
  shows "(\<Sum>p\<leftarrow>primes_upto n. 1 / real p) \<ge> ln (harm n) - ln (5/3)"
proof -
  \<comment> \<open>the set of primes that we will allow in the squarefree part\<close>
  define P where "P n = set (primes_upto n)" for n
  {
    fix n :: nat
    have "finite (P n)" by (simp add: P_def)
  } note [simp] = this

  \<comment> \<open>The function that combines the squarefree part and the square part\<close>
  define f where "f = (\<lambda>(R, s :: nat). \<Prod>R * s^2)"

  \<comment> \<open>@{term f} is injective if the squarefree part contains only primes
      and the square part is positive.\<close>
  have inj: "inj_on f (Pow (P n)\<times>{1..n})"
  proof (rule inj_onI, clarify, rule conjI)
    fix A1 A2 :: "nat set" and s1 s2 :: nat
    assume A: "A1 \<subseteq> P n" "A2 \<subseteq> P n" "s1 \<in> {1..n}" "s2 \<in> {1..n}" "f (A1, s1) = f (A2, s2)"
    have fin: "finite A1" "finite A2" by (rule A(1,2)[THEN finite_subset], simp)+
    show "A1 = A2" "s1 = s2"
      by ((rule squarefree_decomposition_unique2'[of A1 s1 A2 s2],
          insert A fin, auto simp: f_def P_def set_primes_upto)[])+
  qed

  \<comment> \<open>@{term f} hits every number between @{term "1::nat"} and @{term "n"}. It also hits a lot
      of other numbers, but we do not care about those, since we only need a lower bound.\<close>
  have surj: "{1..n} \<subseteq> f ` (Pow (P n)\<times>{1..n})"
  proof
    fix x assume x: "x \<in> {1..n}"
    have "x = f (squarefree_part x, square_part x)" by (simp add: f_def squarefree_decompose)
    moreover have "squarefree_part x \<in> Pow (P n)" using squarefree_part_subset[of x] x
      by (auto simp: P_def set_primes_upto intro: order.trans[OF squarefree_part_le[of _ x]])
    moreover have "square_part x \<in> {1..n}" using x
      by (auto simp: Suc_le_eq intro: order.trans[OF square_part_le[of x]])
    ultimately show "x \<in> f ` (Pow (P n)\<times>{1..n})" by simp
  qed

  \<comment> \<open>We now show the main result by rearranging the sum over all primes to a product over all
      all squarefree parts times a sum over all square parts, and then applying some simple-minded
      approximation\<close>
  have "harm n = (\<Sum>n=1..n. 1 / real n)" by (simp add: harm_def field_simps)
  also from surj have "\<dots> \<le> (\<Sum>n\<in>f ` (Pow (P n)\<times>{1..n}). 1 / real n)"
    by (intro sum_mono2 finite_imageI finite_cartesian_product) simp_all
  also from inj have "\<dots> = (\<Sum>x\<in>Pow (P n)\<times>{1..n}. 1 / real (f x))"
    by (subst sum.reindex) simp_all
  also have "\<dots> = (\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) * (\<Sum>k=1..n. 1 / (real k)^2)" unfolding f_def
    by (subst sum_product, subst sum.cartesian_product) (simp add: case_prod_beta)
  also have "\<dots> \<le> (\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) * (5/3)"
    by (intro mult_left_mono prime_harmonic_aux2 sum_nonneg)
       (auto simp: P_def intro!: prod_nonneg)
  also have "(\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) = (\<Sum>A\<in>((`) real) ` Pow (P n). 1 / \<Prod>A)"
    by (subst sum.reindex) (auto simp: inj_on_def inj_image_eq_iff prod.reindex)
  also have "((`) real) ` Pow (P n) = Pow (real ` P n)" by (intro image_Pow_surj refl)
  also have "(\<Sum>A\<in>Pow (real ` P n). 1 / \<Prod>A) = (\<Prod>x\<in>real ` P n. 1 + 1 / x)"
    by (intro prime_harmonic_aux1 [symmetric] finite_imageI) simp_all
  also have "\<dots> = (\<Prod>i\<in>P n. 1 + 1 / real i)" by (subst prod.reindex) (auto simp: inj_on_def)
  also have "\<dots> \<le> (\<Prod>i\<in>P n. exp (1 / real i))" by (intro prod_mono) auto
  also have "\<dots> = exp (\<Sum>i\<in>P n. 1 / real i)" by (simp add: exp_sum)
  finally have "ln (harm n) \<le> ln (\<dots> * (5/3))" using n
    by (subst ln_le_cancel_iff) simp_all
  hence "ln (harm n) - ln (5/3) \<le> (\<Sum>i\<in>P n. 1 / real i)"
    by (subst (asm) ln_mult) (simp_all add: algebra_simps)
  thus ?thesis unfolding P_def
    by (subst (asm) sum.distinct_set_conv_list) simp_all
qed

text \<open>
  We can use the inequality $\ln (n + 1) \le H_n$ to estimate the asymptotic growth of the partial
  prime harmonic series. Note that $H_n \sim \ln n + \gamma$ where $\gamma$ is the
  Euler--Mascheroni constant (approximately 0.577), so we lose some accuracy here.
\<close>
corollary prime_harmonic_lower':
  assumes n: "n \<ge> 2"
  shows "(\<Sum>p\<leftarrow>primes_upto n. 1 / real p) \<ge> ln (ln (n + 1)) - ln (5/3)"
proof -
  from assms ln_le_harm[of n] have "ln (ln (real n + 1)) \<le> ln (harm n)" by simp
  also from assms have "\<dots> - ln (5/3) \<le> (\<Sum>p\<leftarrow>primes_upto n. 1 / real p)"
    by (rule prime_harmonic_lower)
  finally show ?thesis by - simp
qed

(* TODO: Not needed in Isabelle 2016 *)
lemma Bseq_eventually_mono:
  assumes "eventually (\<lambda>n. norm (f n) \<le> norm (g n)) sequentially" "Bseq g"
  shows   "Bseq f"
proof -
  from assms(1) obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> norm (f n) \<le> norm (g n)"
    by (auto simp: eventually_at_top_linorder)
  from assms(2) obtain K where K: "\<And>n. norm (g n) \<le> K" by (blast elim!: BseqE)
  {
    fix n :: nat
    have "norm (f n) \<le> max K (Max {norm (f n) |n. n < N})"
      apply (cases "n < N")
      apply (rule max.coboundedI2, rule Max.coboundedI, auto) []
      apply (rule max.coboundedI1, force intro: order.trans[OF N K])
      done
  }
  thus ?thesis by (blast intro: BseqI')
qed

lemma Bseq_add:
  assumes "Bseq (f :: nat \<Rightarrow> 'a :: real_normed_vector)"
  shows   "Bseq (\<lambda>x. f x + c)"
proof -
  from assms obtain K where K: "\<And>x. norm (f x) \<le> K" unfolding Bseq_def by blast
  {
    fix x :: nat
    have "norm (f x + c) \<le> norm (f x) + norm c" by (rule norm_triangle_ineq)
    also have "norm (f x) \<le> K" by (rule K)
    finally have "norm (f x + c) \<le> K + norm c" by simp
  }
  thus ?thesis by (rule BseqI')
qed

lemma convergent_imp_Bseq: "convergent f \<Longrightarrow> Bseq f"
  by (simp add: Cauchy_Bseq convergent_Cauchy)

(* END TODO *)

text \<open>
  We now use our last estimate to show that the prime harmonic series diverges. This is obvious,
  since it is bounded from below by $\ln (\ln (n + 1))$ minus some constant, which obviously
  tends to infinite.

  Directly using the divergence of the harmonic series would also be possible and shorten this
  proof a bit..
\<close>
corollary prime_harmonic_series_unbounded:
  "\<not>Bseq (\<lambda>n. \<Sum>p\<leftarrow>primes_upto n. 1 / p)" (is "\<not>Bseq ?f")
proof
  assume "Bseq ?f"
  hence "Bseq (\<lambda>n. ?f n + ln (5/3))" by (rule Bseq_add)
  have "Bseq (\<lambda>n. ln (ln (n + 1)))"
  proof (rule Bseq_eventually_mono)
    from eventually_ge_at_top[of "2::nat"]
      show "eventually (\<lambda>n. norm (ln (ln (n + 1))) \<le> norm (?f n + ln (5/3))) sequentially"
    proof eventually_elim
      fix n :: nat assume n: "n \<ge> 2"
      hence "norm (ln (ln (real n + 1))) = ln (ln (real n + 1))"
        using ln_ln_nonneg[of "real n + 1"] by simp
      also have "\<dots> \<le> ?f n + ln (5/3)" using prime_harmonic_lower'[OF n]
        by (simp add: algebra_simps)
      also have "?f n + ln (5/3) \<ge> 0" by (intro add_nonneg_nonneg sum_list_nonneg) simp_all
      hence "?f n + ln (5/3) = norm (?f n + ln (5/3))" by simp
      finally show "norm (ln (ln (n + 1))) \<le> norm (?f n + ln (5/3))"
        by (simp add: add_ac)
    qed
  qed fact
  then obtain k where k: "k > 0" "\<And>n. norm (ln (ln (real (n::nat) + 1))) \<le> k"
    by (auto elim!: BseqE simp: add_ac)

  define N where "N = nat \<lceil>exp (exp k)\<rceil>"
  have N_pos: "N > 0" unfolding N_def by simp
  have "real N + 1 > exp (exp k)" unfolding N_def by linarith
  hence "ln (real N + 1) > ln (exp (exp k))" by (subst ln_less_cancel_iff) simp_all
  with N_pos have "ln (ln (real N + 1)) > ln (exp k)" by (subst ln_less_cancel_iff) simp_all
  hence "k < ln (ln (real N + 1))" by simp
  also have "\<dots> \<le> norm (ln (ln (real N + 1)))" by simp
  finally show False using k(2)[of N] by simp
qed

corollary prime_harmonic_series_diverges:
  "\<not>convergent (\<lambda>n. \<Sum>p\<leftarrow>primes_upto n. 1 / p)"
  using prime_harmonic_series_unbounded convergent_imp_Bseq by blast

end