theory Backward_Induction
imports "MDP-Rewards.MDP_reward"
begin

locale MDP_reward_fin = discrete_MDP A K
  for
    A and
    K :: "'s ::countable \<times> 'a ::countable \<Rightarrow> 's pmf" +
  fixes
    r :: "('s \<times> 'a) \<Rightarrow> real" and
    r_fin :: "'s \<Rightarrow> real" and
    N :: "nat"
  assumes
    r_fin_bounded: "bounded (range r_fin)" and
    r_bounded_fin: "bounded (range r)"
begin

interpretation MDP_reward A K r 1
  rewrites "1 * (x::real) = x" and "\<And>x.(1::real)^(x::nat)=1"
  using r_bounded_fin
  by unfold_locales (auto simp: algebra_simps)

definition "\<nu>N p s = (\<integral>t. (\<Sum>i<N. r (t !! i)) +  (r_fin (fst(t !! N))) \<partial>\<T> p s)"

lemma measurable_r_fin_nth [measurable]: "(\<lambda>t. r_fin ((t !! i))) \<in> borel_measurable S"
  by measurable

lemma integrable_r_fin_nth [simp]: "integrable (\<T> p s) (\<lambda>t. r_fin (fst(t !! i)))"
  using bounded_range_subset[OF r_fin_bounded]
  by (auto simp: range_composition[of r_fin])

lemma \<nu>N_eq: "\<nu>N p s = (\<Sum>i < N. measure_pmf.expectation (Pn' p s i) r) + measure_pmf.expectation (Xn' p s N) r_fin"
proof -
  have "\<nu>N p s = (\<integral>t. (\<Sum>i<N. r (t !! i)) \<partial>\<T> p s) + (\<integral>t. (r_fin (fst(t !! N))) \<partial>\<T> p s)"
    unfolding \<nu>N_def
    by (auto intro: Bochner_Integration.integral_add)
  moreover have " (\<integral>t. (\<Sum>i<N. r (t !! i)) \<partial>\<T> p s) = (\<Sum>i < N. measure_pmf.expectation (Pn' p s i) r)"
    using \<nu>_fin_Suc \<nu>_fin_eq_Pn by force
  moreover have "(\<integral>t. (r_fin (fst(t !! N))) \<partial>\<T> p s) = measure_pmf.expectation (Xn' p s N) r_fin"
    by (auto simp: Xn'_Pn' Pn'_eq_\<T> integral_distr)
  ultimately show ?thesis by auto
qed

function \<nu>N_eval where
  "\<nu>N_eval p h s = (
    if length h = N then r_fin s else
    if length h > N then 0 else
      measure_pmf.expectation (p h s) (\<lambda>a. r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s'))) "
  by auto

termination
  by (relation "Wellfounded.measure (\<lambda>(_,h,s). N - length h)") auto

lemmas abs_disc_eq[simp del]
lemmas \<nu>N_eval.simps[simp del]

lemma pmf_bounded_integrable: "bounded (range (f::_ \<Rightarrow> real)) \<Longrightarrow> integrable (measure_pmf p) f"
  using bounded_norm_le_SUP_norm[of f]
  by (intro measure_pmf.integrable_const_bound[of _ "\<Squnion>x. \<bar>f x\<bar>"]) auto

lemma abs_boundedD[dest]: "(\<And>x. \<bar>f x\<bar> \<le> (c::real)) \<Longrightarrow> bounded (range f)"
  using bounded_real by auto

lemma abs_integral_le[intro]: "(\<And>x. \<bar>f x\<bar> \<le> (c::real)) \<Longrightarrow> abs (measure_pmf.expectation p f) \<le> c"
  by (fastforce intro!: pmf_bounded_integrable abs_boundedD measure_pmf.integral_le_const order.trans[OF integral_abs_bound])

lemma abs_\<nu>N_eval_le: "\<bar>\<nu>N_eval p h s\<bar> \<le> (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
proof (induction "(N - length h)" arbitrary: h s)
  case 0
  then show ?case
    using r_fin_bounded
    by (auto simp: \<nu>N_eval.simps intro!: bounded_imp_bdd_above cSUP_upper2)
next
  case (Suc x)
  have "N > length h"
    using Suc(2) by linarith
  hence Suc_le: "Suc (length h) \<le> N"
    by auto
  have *: "\<bar>\<nu>N_eval p (h @ [(s, a)]) s'\<bar> \<le> real (N - length h - 1) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a s'
    using Suc.hyps(1)[of "h @[(s,a)]"] Suc.hyps(2)
    by (auto simp: of_nat_diff[OF Suc_le] algebra_simps)
  hence **: "\<bar>measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])))\<bar>
    \<le> real (N - length h - 1) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
    using Suc by auto
  have "\<bar>measure_pmf.expectation (p h s) (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])))\<bar>
      \<le> \<bar>measure_pmf.expectation (p h s) (\<lambda>a. r (s, a))  + measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])))\<bar>"
    using abs_r_le_r\<^sub>M
    by (subst Bochner_Integration.integral_add) (auto intro!: abs_boundedD * pmf_bounded_integrable)
  also have "\<dots> \<le> \<bar>measure_pmf.expectation (p h s) (\<lambda>a. r (s, a))\<bar>  + \<bar> measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])))\<bar>"
    by auto
  also have "\<dots> \<le> r\<^sub>M  + \<bar> measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])))\<bar>"
    using abs_r_le_r\<^sub>M by auto
  also have "\<dots> \<le> r\<^sub>M  + (N - length h - 1) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
    using "**" by force
  also have "\<dots> \<le> (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
    using Suc Suc_le by (auto simp: of_nat_diff algebra_simps)
  finally show ?case
    using \<nu>N_eval.simps \<open>length h < N\<close> by force
qed

lemma abs_\<nu>N_eval_le': "\<bar>\<nu>N_eval p h s\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  by (simp add: mult_left_mono r\<^sub>M_nonneg algebra_simps order.trans[OF abs_\<nu>N_eval_le[of p h s]])

lemma measure_pmf_expectation_bind:
  assumes "bounded (range f)"
  shows "measure_pmf.expectation (p \<bind> q) (f::_ \<Rightarrow> real) = measure_pmf.expectation p (\<lambda>x. measure_pmf.expectation (q x) f)"
  unfolding measure_pmf_bind
  using assms measure_pmf_in_subprob_space
  by (fastforce intro!: Giry_Monad.integral_bind[of _ "count_space UNIV" "\<Squnion>x. \<bar>f x\<bar>"] bounded_imp_bdd_above cSUP_upper)+

lemma Pn'_shift: "bounded (range (f :: _ \<Rightarrow> real)) \<Longrightarrow> measure_pmf.expectation (p h s)
     (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ (s, a)# h'))) s' n) f))
    = measure_pmf.expectation (Pn' (\<lambda>h'. p (h @ h')) s (Suc n)) f"
  unfolding PSuc' \<pi>_Suc_def K0'_def
  by (auto simp: measure_pmf_expectation_bind)

lemma bounded_r_snd': "bounded ((\<lambda>a. r (s, a)) ` X)"
  using r_bounded' image_image
  by metis

lemma bounded_r_snd: "bounded (range (\<lambda>a. r (s, a)))"
  using bounded_r_snd'.

lemma \<nu>N_eval_eq: "length h \<le> N \<Longrightarrow> \<nu>N_eval p h s =
  (\<Sum>i \<in>{length h..< N}.
  measure_pmf.expectation (Pn' (\<lambda>h'. p (h@h')) s (i - length h)) r) + measure_pmf.expectation (Xn' (\<lambda>h'. p (h@h')) s (N - length h)) r_fin"
proof (induction "N - length h" arbitrary: h s)
  case 0
  then show ?case
    using \<nu>N_eval.simps by auto
next
  case (Suc x)
  hence "length h < N"
    by auto
  hence
    "\<nu>N_eval p h s =
      measure_pmf.expectation (p h s) (\<lambda>a. r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s'))"
    by (auto simp: \<nu>N_eval.simps[of p h] split: if_splits)
  also have "\<dots> =
      measure_pmf.expectation (p h s) (\<lambda>a. r (s,a)) + measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s'))"
    using abs_\<nu>N_eval_le' bounded_r_snd
    by (fastforce simp: bounded_real intro!: Bochner_Integration.integral_add pmf_bounded_integrable abs_integral_le)
  also have "\<dots> =
    (\<Sum>i = length h..<N. measure_pmf.expectation (Pn' (\<lambda>h'. p (h @ h')) s (i - length h)) r) + measure_pmf.expectation (Xn' (\<lambda>h'. p (h @ h')) s (N - length h)) r_fin"
  proof -
    have "measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s')) =
    measure_pmf.expectation (p h s)
     (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. (\<Sum>i = length (h @ [(s, a)])..<N. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length (h @ [(s, a)]))) r) +
                   measure_pmf.expectation (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length (h @ [(s, a)]))) r_fin))"
      using Suc \<open>length h < N\<close>
      by auto
    also have "\<dots> =
    measure_pmf.expectation (p h s)
     (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. (\<Sum>i = length h + 1..<N. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length h - 1)) r) +
                   measure_pmf.expectation (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length h - 1)) r_fin))"
      using Suc \<open>length h < N\<close> K0'_def
      by auto
    also have "\<dots> =
    measure_pmf.expectation (p h s)
     (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. (\<Sum>i = length h + 1..<N. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length h - 1)) r)) +
          measure_pmf.expectation (K (s, a))
            (\<lambda>s'. measure_pmf.expectation (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length h - 1)) r_fin))"
      using abs_exp_r_le r_fin_bounded
      by (fastforce intro!: Bochner_Integration.integral_cong[OF refl] Bochner_Integration.integral_add
          pmf_bounded_integrable Bochner_Integration.integrable_sum simp: bounded_real)+
    also have "\<dots> =
    measure_pmf.expectation (p h s)
     (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. (\<Sum>i = length h + 1..<N. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length h - 1)) r))) +
      measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<lambda>s'. measure_pmf.expectation
        (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length h - 1)) r_fin))"
      using abs_r_le_r\<^sub>M r_fin_bounded
      by (fastforce intro!:
         Bochner_Integration.integral_add Bochner_Integration.integrable_sum pmf_bounded_integrable
         abs_integral_le order.trans[OF sum_abs] order.trans[OF sum_bounded_above[of _ _ "r\<^sub>M"]] simp: bounded_real)
    also have "\<dots> = measure_pmf.expectation (p h s) (\<lambda>a. (\<Sum>i = length h + 1..<N. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length h - 1)) r))) +
      measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<lambda>s'. measure_pmf.expectation
        (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length h - 1)) r_fin))"
      using abs_r_le_r\<^sub>M
      by (subst Bochner_Integration.integral_sum) (auto intro!: pmf_bounded_integrable boundedI[of _ "r\<^sub>M"] abs_integral_le)
    also have "\<dots> = (\<Sum>i = length h + 1..<N. measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a))
            (\<lambda>s'. measure_pmf.expectation (Pn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (i - length h - 1)) r))) +
      measure_pmf.expectation (p h s) (\<lambda>a. measure_pmf.expectation (K (s, a)) (\<lambda>s'. measure_pmf.expectation
        (Xn' (\<lambda>h'. p ((h @ [(s, a)]) @ h')) s' (N - length h - 1)) r_fin))"
      using abs_r_le_r\<^sub>M
      by (subst Bochner_Integration.integral_sum) (auto intro!: pmf_bounded_integrable boundedI[of _ "r\<^sub>M"] abs_integral_le)
    also have "\<dots> =
      (\<Sum>i = length h + 1..<N. (measure_pmf.expectation (Pn' (\<lambda>h'. p (h @ h')) s (i - length h))) r) +
      measure_pmf.expectation (Xn' (\<lambda>h'. p (h @ h')) s (N - length h)) r_fin"
      using r_bounded r_fin_bounded \<open>length h < N\<close>
      by (auto simp add: Pn'_shift Xn'_Pn' Suc_diff_Suc range_composition)
    finally show ?thesis
      unfolding sum.atLeast_Suc_lessThan[OF \<open>length h < N\<close>] r_dec_eq_r_K0
      by auto
  qed
  finally show ?case .
qed

lemma \<nu>N_eval_correct: "\<nu>N_eval p [] s = \<nu>N p s"
  using lessThan_atLeast0
  by (auto simp: \<nu>N_eq \<nu>N_eval_eq)

lift_definition \<nu>N\<^sub>b :: "('s, 'a) pol \<Rightarrow> 's \<Rightarrow>\<^sub>b real" is \<nu>N
  using r_fin_bounded
  by (intro bfun_normI[of _ "r\<^sub>M * N + (\<Squnion>x. \<bar>r_fin x\<bar>)"])
    (auto simp add: \<nu>N_eq r\<^sub>M_def r_bounded bounded_abs_range intro!: add_mono
      order.trans[OF integral_abs_bound] pmf_bounded_integrable  lemma_4_3_1
      order.trans[OF sum_abs] order.trans[OF abs_triangle_ineq] order.trans[OF sum_bounded_above[of _ _ r\<^sub>M]])

definition "\<nu>N_opt s = (\<Squnion>p \<in> \<Pi>\<^sub>H\<^sub>R. \<nu>N p s)"
definition "\<nu>N_eval_opt h s = (\<Squnion>p \<in> \<Pi>\<^sub>H\<^sub>R. \<nu>N_eval p h s)"

function \<nu>N_opt_eqn where
  "\<nu>N_opt_eqn h s = (
    if length h = N then r_fin s else
    if length h > N then 0 else
      \<Squnion>a \<in> A s. (r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_opt_eqn (h@[(s,a)]) s'))) "
  by auto

termination
  by (relation "Wellfounded.measure (\<lambda>(h,s). N - length h)") auto

lemmas \<nu>N_opt_eqn.simps[simp del]

lemma abs_\<nu>N_opt_eqn_le: "\<bar>\<nu>N_opt_eqn h s\<bar> \<le> (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
proof (induction "(N - length h)" arbitrary: h s)
  case 0
  then show ?case
    using r_fin_bounded
    by (auto simp: \<nu>N_opt_eqn.simps intro!: bounded_imp_bdd_above cSUP_upper2)
next
  case (Suc x)
  have "N > length h"
    using Suc(2) by linarith
  have *: "\<bar>\<nu>N_opt_eqn (h @ [(s, a)]) s'\<bar> \<le> real (N - length h - 1) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a s'
    using Suc(1)[of "(h @ [(s, a)])"] Suc(2)
    by auto
  hence "\<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))\<bar>
    \<le> real (N - length h - 1) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a
    using Suc by auto
  hence **: "r\<^sub>M + \<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))\<bar>
    \<le> real (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a
    using Suc
    by (auto simp: of_nat_diff algebra_simps)
  hence *: "\<bar>r (s, a)\<bar> + \<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))\<bar> \<le> real (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a
    using abs_r_le_r\<^sub>M
    by (meson add_le_cancel_right  order.trans)
  hence *: "\<bar>r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))\<bar> \<le> real (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)" for a
    using order.trans[OF abs_triangle_ineq] by auto
  have "\<bar>\<nu>N_opt_eqn h s\<bar> = \<bar>\<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))\<bar>"
    unfolding \<nu>N_opt_eqn.simps[of h] using \<open>length h < N\<close>
    by auto
  also have "\<dots> \<le> \<bar>\<Squnion>a\<in>A s. measure_pmf.expectation (return_pmf a) (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)])))\<bar>"
    by auto
  also have "\<dots> \<le> (\<Squnion>a\<in>A s. \<bar> measure_pmf.expectation (return_pmf a) (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)])))\<bar>)"
    using \<open>length h < N\<close> A_ne  *
    by (auto intro!: boundedI abs_cSUP_le)
  also have "\<dots> \<le> real (N - length h) * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
    using * A_ne
    by (auto intro!: cSUP_least)
  finally show ?case.
qed

lemma abs_\<nu>N_opt_eqn_le': "\<bar>\<nu>N_opt_eqn h s\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  by (simp add: mult_left_mono r\<^sub>M_nonneg algebra_simps order.trans[OF abs_\<nu>N_opt_eqn_le[of h s]])

lemma abs_\<nu>N_eval_opt_le': "\<bar>\<nu>N_eval_opt h s\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  unfolding \<nu>N_eval_opt_def
  using policies_ne abs_\<nu>N_eval_le'
  by (auto intro!: order.trans[OF abs_cSUP_le] boundedI cSUP_least)

lemma exp_\<nu>N_eval_opt_le: "\<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_eval_opt h)\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  by (metis abs_\<nu>N_eval_opt_le' abs_integral_le)

lemma bounded_exp_\<nu>N_eval_opt: "(bounded ((\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval_opt (h a))) ` X))"
  using exp_\<nu>N_eval_opt_le
  by (auto intro!: boundedI)

lemma bounded_r_exp_\<nu>N_eval_opt: "(bounded ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval_opt (h a))) ` X))"
  using bounded_exp_\<nu>N_eval_opt r_bounded abs_r_le_r\<^sub>M
  by (intro bounded_plus_comp) (auto intro!:  boundedI)

lemma integrable_r_exp_\<nu>N_eval_opt: "(integrable (measure_pmf q) ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval_opt (h a)))))"
  using bounded_r_exp_\<nu>N_eval_opt pmf_bounded_integrable by blast

lemma exp_\<nu>N_eval_le: "\<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_eval p h)\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  by (metis abs_\<nu>N_eval_le' abs_integral_le)

lemma bounded_exp_\<nu>N_eval: "(bounded ((\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h a))) ` X))"
  using exp_\<nu>N_eval_le
  by (auto intro!: boundedI)

lemma bounded_r_exp_\<nu>N_eval: "(bounded ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h a))) ` X))"
  using bounded_exp_\<nu>N_eval r_bounded abs_r_le_r\<^sub>M
  by (intro bounded_plus_comp) (auto intro!:  boundedI)

lemma integrable_r_exp_\<nu>N_eval: "(integrable (measure_pmf q) ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h a)))))"
  using bounded_r_exp_\<nu>N_eval pmf_bounded_integrable by blast

lemma exp_\<nu>N_opt_eqn_le: "\<bar>measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn h)\<bar> \<le> N * r\<^sub>M + (\<Squnion>s. \<bar>r_fin s\<bar>)"
  by (metis abs_\<nu>N_opt_eqn_le' abs_integral_le)

lemma bounded_exp_\<nu>N_opt_eqn: "(bounded ((\<lambda>a. measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h a))) ` X))"
  using exp_\<nu>N_opt_eqn_le
  by (auto intro!: boundedI)

lemma bounded_r_exp_\<nu>N_opt_eqn: "(bounded ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h a))) ` X))"
  using bounded_exp_\<nu>N_opt_eqn r_bounded abs_r_le_r\<^sub>M
  by (intro bounded_plus_comp) (auto intro!:  boundedI)

lemma integrable_r_exp_\<nu>N_opt_eqn: "(integrable (measure_pmf q) ((\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h a)))))"
  using bounded_r_exp_\<nu>N_opt_eqn pmf_bounded_integrable by blast

lemma \<nu>N_eval_le_opt_eqn: "p \<in> \<Pi>\<^sub>H\<^sub>R \<Longrightarrow> \<nu>N_eval p h s \<le> \<nu>N_opt_eqn h s"
proof (induction p h s rule: \<nu>N_eval.induct)
  case (1 p h s)
  have "\<nu>N_eval p (h @ [(s, a)]) s' \<le> \<nu>N_opt_eqn (h @[(s,a)]) s'" if "length h < N" for a s'
    using that 1 by fastforce
  hence *: "r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_eval p (h @ [(s, a)])) \<le> r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))" if "length h < N" for a
    using abs_\<nu>N_eval_le' abs_\<nu>N_opt_eqn_le' that
    by (fastforce intro!: integral_mono pmf_bounded_integrable simp: bounded_real)
  have **: "a \<in> set_pmf (p h s) \<Longrightarrow> a \<in> A s" for a
    using 1 is_dec_def is_policy_def by blast
  then show ?case
    unfolding \<nu>N_eval.simps[of p h] \<nu>N_opt_eqn.simps[of h]
    using integrable_r_exp_\<nu>N_eval bounded_r_exp_\<nu>N_eval bounded_r_exp_\<nu>N_opt_eqn *
    by (auto simp: set_pmf_not_empty intro!: order.trans[OF lemma_4_3_1] cSUP_mono bexI bounded_imp_bdd_above)
  qed

lemma \<nu>N_eval_le_opt: "p\<in>\<Pi>\<^sub>H\<^sub>R \<Longrightarrow> \<nu>N_eval_opt h s \<ge> \<nu>N_eval p h s"
  unfolding \<nu>N_eval_opt_def
  using bounded_subset_range[OF abs_boundedD[OF abs_\<nu>N_eval_le']]
  by (force intro!: cSUP_upper abs_boundedD bounded_imp_bdd_above)

lemma \<nu>N_opt_eqn_bounded[simp, intro]: "bounded ((\<nu>N_opt_eqn h) ` X)"
  by (meson Blinfun_Util.bounded_subset abs_\<nu>N_opt_eqn_le' abs_boundedD subset_UNIV)

lemma \<nu>N_eval_opt_bounded[simp, intro]: "bounded ((\<nu>N_eval_opt h) ` X)"
  by (meson Blinfun_Util.bounded_subset abs_\<nu>N_eval_opt_le' abs_boundedD subset_UNIV)

lemma \<nu>N_eval_bounded[simp, intro]: "bounded ((\<nu>N_eval p h) ` X)"
  by (meson Blinfun_Util.bounded_subset abs_\<nu>N_eval_le' abs_boundedD subset_UNIV)

lemma \<nu>N_opt_ge: "length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<ge> \<nu>N_eval_opt h s"
proof (induction "N - length h" arbitrary: h s)
  case 0
  then show ?case
    unfolding \<nu>N_eval_opt_def \<nu>N_opt_eqn.simps[of h]
    using policies_ne
    by (subst \<nu>N_eval_eq) auto
next
  case (Suc x)
  hence "length h < N"
    by linarith
  {
    fix p assume "p \<in> \<Pi>\<^sub>H\<^sub>R"
    have "\<nu>N_eval p h s = measure_pmf.expectation (p h s) (\<lambda>a. (r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s')))"
      unfolding \<nu>N_eval.simps[of p h]
      using \<open>length h < N\<close>
      by auto
    also have "\<dots> \<le> (\<Squnion>a \<in> A s. (r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_eval p (h@[(s,a)]) s')))"
      using \<open>p \<in> \<Pi>\<^sub>H\<^sub>R\<close> is_dec_def is_policy_def bounded_r_snd' bounded_exp_\<nu>N_eval
      by (auto intro!: lemma_4_3_1 bounded_plus_comp pmf_bounded_integrable simp: r_bounded')
    also have "\<dots> \<le> (\<Squnion>a \<in> A s. (r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. \<nu>N_opt_eqn (h@[(s,a)]) s')))"
    proof -
      have "a \<in> A s \<Longrightarrow>
        r (s,a) + measure_pmf.expectation (K (s,a)) (\<nu>N_eval p (h @ [(s,a)])) \<le>
        r (s,a) + measure_pmf.expectation (K (s,a)) (\<nu>N_eval_opt (h@[(s,a)]))" for a
        using abs_boundedD[OF abs_\<nu>N_eval_opt_le'] abs_boundedD[OF abs_\<nu>N_eval_le']
        using \<nu>N_eval_le_opt \<open>p \<in> \<Pi>\<^sub>H\<^sub>R\<close>
        by (force intro!: integral_mono pmf_bounded_integrable)
      moreover have "a \<in> A s \<Longrightarrow>
        r (s,a) + measure_pmf.expectation (K (s,a)) (\<nu>N_eval_opt (h@[(s,a)])) \<le>
        r (s,a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn (h@[(s,a)]))" for a
        using \<nu>N_eval_le_opt_eqn policies_ne Suc
        by (auto intro!: integral_mono pmf_bounded_integrable cSUP_least)
      ultimately show ?thesis
        using A_ne bounded_imp_bdd_above bounded_r_exp_\<nu>N_opt_eqn
        by (fastforce intro!: cSUP_mono)+
    qed
    also have "\<dots> = \<nu>N_opt_eqn h s"
      unfolding \<nu>N_opt_eqn.simps[of h]
      using \<open>length h < N\<close>
      by auto
    finally have "\<nu>N_opt_eqn h s \<ge> \<nu>N_eval p h s".
  }
  then show ?case
    unfolding \<nu>N_eval_opt_def
    using policies_ne
    by (auto intro!: cSUP_least)
qed

lemma Sup_wit_ex:
  assumes "(d ::real)> 0"
  assumes "X \<noteq> {}"
  assumes "bdd_above (f ` X)"
  shows "\<exists>x \<in> X. (\<Squnion>x \<in> X. f x) < f x + d"
proof -
  have "\<exists>x \<in>X. (\<Squnion>x \<in> X. f x) - d < f x"
    using assms
    by (auto simp: less_cSUP_iff[symmetric])
  thus ?thesis
    by force
qed

lemma \<nu>N_opt_eqn_markov: "length h \<le> N \<Longrightarrow> length h = length h' \<Longrightarrow> \<nu>N_opt_eqn h = \<nu>N_opt_eqn h'"
proof (induction "N - length h" arbitrary: h h')
  case 0
  then show ?case
    by (auto simp: \<nu>N_opt_eqn.simps)
next
  case (Suc x)
  {
    fix s
    have "\<nu>N_opt_eqn h s = (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K(s,a)) (\<nu>N_opt_eqn (h@[(s,a)])))"
      using  Suc by (fastforce simp: \<nu>N_opt_eqn.simps)
    also have "\<dots> = (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K(s,a)) (\<nu>N_opt_eqn (h'@[(s,a)])))"
      using Suc
      by (auto intro!: SUP_cong Bochner_Integration.integral_cong Suc(1)[THEN cong])
    also have "\<dots> = \<nu>N_opt_eqn h' s"
      using Suc \<nu>N_opt_eqn.simps by fastforce
    finally have "\<nu>N_opt_eqn h s = \<nu>N_opt_eqn h' s ".
  }
  thus ?case by auto
qed

lemma \<nu>N_opt_le:
  fixes eps :: real
  assumes "eps > 0"
  shows "\<exists>p \<in> \<Pi>\<^sub>M\<^sub>D. \<forall>h s. length h \<le> N \<longrightarrow> \<nu>N_eval (mk_markovian_det p) h s + real (N - length h) * eps \<ge> \<nu>N_opt_eqn h s"
proof -
  define p where "p = (\<lambda>n s. if n \<ge> N then SOME a. a \<in> A s else
      SOME a. a \<in> A s \<and>
        r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (replicate n (s, SOME a. a \<in> A s) @ [(s,a)])) + eps > \<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)) s)"
  have *: "\<exists>a . a \<in> A s \<and>
        r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h@[(s,a)])) + eps > \<nu>N_opt_eqn h s"
    if "length h < N"
    for h s
    using that Sup_wit_ex[OF assms A_ne, unfolded Bex_def] bounded_imp_bdd_above bounded_r_exp_\<nu>N_opt_eqn
    by (auto simp: \<nu>N_opt_eqn.simps)
  hence **: "\<exists>a . a \<in> A s \<and>
        r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn ((replicate n (s,SOME a. a \<in> A s))@[(s,a)])) + eps > \<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)) s"
    if "n < N" for n s
    using that by simp
  have p_prop: "p n s \<in> A s \<and> r (s, p n s) + measure_pmf.expectation (K (s, p n s)) (\<nu>N_opt_eqn ((replicate n (s,SOME a. a \<in> A s))@[(s,p n s)])) + eps > \<nu>N_opt_eqn ((replicate n (s,SOME a. a \<in> A s))) s"
    if "n < N" for n s
    using someI_ex[OF **[OF that], of s] that
    by (auto simp: p_def)
  hence p_prop': "p (length h) s \<in> A s \<and> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s,p (length h) s)])) + eps > \<nu>N_opt_eqn h s"
    if "length h < N" for h s
    using that
    by (auto simp:
        \<nu>N_opt_eqn_markov[of h "(replicate (length h) (s,SOME a. a \<in> A s))"]
        \<nu>N_opt_eqn_markov[of "(h@[(s,p (length h) s)])" "(replicate (length h) (s, SOME a. a \<in> A s) @ [(s, p (length h) s)])"])
  have "p n s \<in> A s" for n s
    using SOME_is_dec_det is_dec_det_def p_def p_prop by auto
  hence p:"p \<in> \<Pi>\<^sub>M\<^sub>D"
    using is_dec_det_def by force
  {
    fix h s p
    assume "p \<in> \<Pi>\<^sub>M\<^sub>D"
      and
      p: "\<And>h s. length h < N \<Longrightarrow> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s,p (length h) s)])) + eps > \<nu>N_opt_eqn h s"
    have "length h \<le> N \<Longrightarrow> \<nu>N_eval (mk_markovian_det p) h s + real (N - length h) * eps \<ge> \<nu>N_opt_eqn h s"
    proof (induction "N - length h" arbitrary: h s)
      case 0
      hence *: "length h = N"
        by auto
      thus ?case
        by (auto simp: \<nu>N_opt_eqn.simps \<nu>N_eval.simps)
    next
      case (Suc x)
      hence *: "length h < N"
        by auto
      have "\<nu>N_opt_eqn h s - real (N - length h) * eps < r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s,p (length h) s)])) - real (N - length h) * eps + eps"
        using p[OF *, of s] by auto
      also have "\<dots> = r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s,p (length h) s)])) - real (N - length h - 1) * eps"
      proof -
        have "real (N - length h - 1) = real (N - length h) - 1"
          using * by (auto simp: algebra_simps)
        thus ?thesis
          by algebra
      qed
      also have "\<dots> = r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<lambda>s'. \<nu>N_opt_eqn (h@[(s,p (length h) s)]) s' - real (N - length h - 1) * eps)"
        by (subst Bochner_Integration.integral_diff) (auto intro: pmf_bounded_integrable)
      also have "\<dots> \<le> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_eval (mk_markovian_det p) (h@[(s,p (length h) s)]))"
        using Suc(1)[of "h@[_]"] Suc *
        by (auto simp: algebra_simps intro!: integral_mono pmf_bounded_integrable bounded_minus_comp)
      also have "\<dots> = \<nu>N_eval (mk_markovian_det p) h s"
        using Suc
        by (auto simp: mk_markovian_det_def \<nu>N_eval.simps)
      finally show ?case
        by auto
    qed
  }
  thus ?thesis
    using p p_prop' by blast
qed

lemma \<nu>N_opt_le':
  fixes eps :: real
  assumes "eps > 0"
  shows "\<exists>p \<in> \<Pi>\<^sub>M\<^sub>D. \<forall>h s. length h \<le> N \<longrightarrow> \<nu>N_eval (mk_markovian_det p) h s + eps \<ge> \<nu>N_opt_eqn h s"
proof -
  obtain p where "p\<in>\<Pi>\<^sub>M\<^sub>D" and "\<And>h s. length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval (mk_markovian_det p) h s + real (N - length h) * (eps/N)"
    using \<nu>N_opt_le[of "eps / N"] \<nu>N_opt_le assms
    by (cases "N = 0") force+
  hence **: "\<And>h s. length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval (mk_markovian_det p) h s + eps - ((eps * length h) / N)"
    using assms
    by (cases "N = 0") (auto simp: algebra_simps of_nat_diff intro: add_increasing)
  moreover have *:"eps * real (length h) / N \<ge> 0" for h
    using assms by auto
  ultimately have "\<And>h s. length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval (mk_markovian_det p) h s + eps"
    by (auto intro!: order.trans[OF **])
  thus ?thesis
    using \<open>p \<in> \<Pi>\<^sub>H\<^sub>D\<close> by blast
qed

lemma mk_det_preserves: "p \<in> \<Pi>\<^sub>H\<^sub>D \<Longrightarrow> (mk_det p) \<in> \<Pi>\<^sub>H\<^sub>R"
  unfolding is_policy_def mk_det_def
  by (auto simp: is_dec_def is_dec_det_def)

lemma mk_markovian_det_preserves: "p \<in> \<Pi>\<^sub>M\<^sub>D \<Longrightarrow> (mk_markovian_det p) \<in> \<Pi>\<^sub>H\<^sub>R"
  unfolding is_policy_def mk_markovian_det_def
  by (auto simp: is_dec_def is_dec_det_def)

lemma \<nu>N_opt_eq:
  assumes "length h \<le> N"
  shows "\<nu>N_opt_eqn h s = \<nu>N_eval_opt h s"
proof -
  {
    fix eps :: real
    assume "0 < eps"
    hence "\<exists>p\<in>\<Pi>\<^sub>H\<^sub>R. \<forall>h s. length h \<le> N \<longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval p h s + eps"
    using mk_markovian_det_preserves \<nu>N_opt_le'[of eps]
    by auto
  then obtain p where "p\<in>\<Pi>\<^sub>H\<^sub>R" and **: "length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval p h s + eps" for h s
    by auto
  hence "length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval_opt h s + eps" for h s
    using \<nu>N_eval_le_opt[of p]
    by (auto intro:  order.trans[OF **])
  }
  hence "length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval_opt h s"
    by (meson field_le_epsilon)
  thus ?thesis
    using \<nu>N_opt_ge assms antisym by auto
qed

lemma \<nu>N_opt_eqn_correct: "\<nu>N_opt s = \<nu>N_opt_eqn [] s"
  using \<nu>N_eval_correct \<nu>N_eval_opt_def \<nu>N_opt_def \<nu>N_opt_eq by force

lemma thm_4_3_4:
  assumes "eps \<ge> 0" "p \<in> \<Pi>\<^sub>M\<^sub>D"
    and "\<And>h s. length h < N \<Longrightarrow> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s, p (length h) s)])) + eps
    \<ge> (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn (h@[(s, a)])))"
  shows "\<And>h s.  length h \<le> N \<Longrightarrow> \<nu>N_eval (mk_markovian_det p) h s + (N - length h) * eps \<ge> \<nu>N_opt_eqn h s"
    "\<And>s. \<nu>N (mk_markovian_det p) s + N * eps \<ge> \<nu>N_opt s"
proof -
  show "\<nu>N_eval (mk_markovian_det p) h s + (N - length h) * eps \<ge> \<nu>N_opt_eqn h s" if "length h \<le> N" for h s
    using assms that
  proof (induction "N - length h" arbitrary: h s)
    case 0
    then show ?case
      using \<nu>N_eval.simps \<nu>N_opt_eqn.simps by force
  next
    case (Suc x)
    have "\<nu>N_opt_eqn h s = (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn (h@[(s, a)])))"
      using Suc.hyps(2) \<nu>N_opt_eqn.simps by fastforce
    also have "\<dots> \<le> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h@[(s, p (length h) s)])) + eps"
      using Suc.hyps(2) Suc.prems(3)
      by simp
    also have "\<dots> \<le> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<lambda>s'. \<nu>N_eval (mk_markovian_det p) (h@[(s, p (length h) s)]) s' +
    (N - length (h@[(s,p (length h) s)])) * eps) + eps"
      using Suc(1)[of "(h@[(s,p (length h) s)])"] Suc.hyps(2) assms
      by (auto intro!: integral_mono pmf_bounded_integrable bounded_plus_comp)
    also have "\<dots> = r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_eval (mk_markovian_det p) (h@[(s, p (length h) s)])) + (N - length h) * eps"
      using Suc
      by (subst Bochner_Integration.integral_add) (auto simp: of_nat_diff left_diff_distrib distrib_right intro!: pmf_bounded_integrable)
    also have "\<dots> = \<nu>N_eval (mk_markovian_det p) h s + (N - length h) * eps"
      using Suc
      by (auto simp add: \<nu>N_eval.simps mk_markovian_det_def)
    finally show ?case.
  qed
  from this[of  "[]"] show "\<nu>N (mk_markovian_det p) s + N * eps \<ge> \<nu>N_opt s" for s
    using \<nu>N_eval_correct \<nu>N_opt_eqn_correct
    by auto
qed

lemma \<nu>N_has_eps_opt_pol:
  assumes "eps > 0"
  shows "\<exists>p \<in> \<Pi>\<^sub>M\<^sub>D. \<forall>s. \<nu>N (mk_markovian_det p) s + eps \<ge> \<nu>N_opt s"
proof -
  obtain p where "p\<in>\<Pi>\<^sub>M\<^sub>D" and
    P: "\<And>h s. length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval (mk_markovian_det p) h s + eps"
    using \<nu>N_opt_le'[of eps] assms by auto
  from P[of "[]"] have "\<nu>N_opt_eqn [] s \<le> \<nu>N_eval (mk_markovian_det p) [] s + eps" for s
    by auto
  thus ?thesis
    unfolding \<nu>N_opt_eqn_correct
    using \<nu>N_eval_correct \<open>p \<in> \<Pi>\<^sub>H\<^sub>D\<close> by auto
qed

lemma \<nu>N_le_opt: "p \<in> \<Pi>\<^sub>H\<^sub>R \<Longrightarrow> \<nu>N p s \<le> \<nu>N_opt s"
  by (metis \<nu>N_eval_correct \<nu>N_eval_le_opt_eqn \<nu>N_opt_eqn_correct)

lemma \<nu>N_has_opt_pol:
  assumes "\<And>h s.
    length h < N
    \<Longrightarrow> \<exists>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn (h@[(s,a)]))
    = (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn (h@[(s,a)])))"
  shows "\<exists>p \<in> \<Pi>\<^sub>M\<^sub>D. \<forall>s. \<nu>N (mk_markovian_det p) s = \<nu>N_opt s"
proof -
  define p where "p = (\<lambda>n s. if n \<ge> N then SOME a. a \<in> A s else
      SOME a. a \<in> A s \<and>
        r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)@[(s,a)])) = \<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)) s
)"
  have p_short: "p n s = (
      SOME a. a \<in> A s \<and>
        r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)@[(s,a)])) = \<nu>N_opt_eqn (replicate n (s,SOME a. a \<in> A s)) s)"
    if "n < N" for n s
    unfolding p_def using that by auto
  have *: "p n s \<in> A s"
    "(n < N \<Longrightarrow>  r (s, p n s) + measure_pmf.expectation (K (s,p n s)) (\<nu>N_opt_eqn ((replicate n (s,SOME a. a \<in> A s))@[(s,p n s)]))
    = (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn ((replicate n (s,SOME a. a \<in> A s))@[(s,a)]))))" for n s
      using someI_ex[OF assms[unfolded Bex_def]] SOME_is_dec_det
      by (auto simp: \<nu>N_opt_eqn.simps is_dec_det_def p_def)
    have "\<nu>N (mk_markovian_det p) s \<ge> \<nu>N_opt s" for s
    proof (intro thm_4_3_4(2)[of 0 p, simplified])
      show "\<forall>n. is_dec_det (p n)"
        using *
        by (auto simp: is_dec_det_def)
    next
      {
        fix h :: "('s \<times> 'a) list" and s
        assume "length h < N"
        have "(\<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)]))) =
          (\<Squnion>a \<in> A s. r (s, a) + measure_pmf.expectation (K (s,a)) (\<nu>N_opt_eqn ((replicate (length h) (s,SOME a. a \<in> A s))@[(s,a)])))"
          using \<open>length h < N\<close>
          by (auto intro!: SUP_cong Bochner_Integration.integral_cong \<nu>N_opt_eqn_markov[THEN cong])
        also have "\<dots> = r (s, p (length h) s) + measure_pmf.expectation (K (s,p (length h) s)) (\<nu>N_opt_eqn ((replicate (length h) (s,SOME a. a \<in> A s))@[(s,p (length h) s)]))"
          using * \<open>length h < N\<close> by presburger
        also have "\<dots> = r (s, p (length h) s) + measure_pmf.expectation (K (s,p (length h) s)) (\<nu>N_opt_eqn (h@[(s,p (length h) s)]))"
          using \<open>length h < N\<close>
          by (auto intro!: Bochner_Integration.integral_cong \<nu>N_opt_eqn_markov[THEN cong])
        finally show "(\<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)])))
           \<le> r (s, p (length h) s) + measure_pmf.expectation (K (s, p (length h) s)) (\<nu>N_opt_eqn (h @ [(s, p (length h) s)]))"
          by auto
      }
    qed
    hence "\<nu>N (mk_markovian_det p) s = \<nu>N_opt s" for s
      using \<nu>N_le_opt *(1) mk_markovian_det_preserves
      by (simp add: is_dec_det_def order_antisym)
    thus ?thesis
      using *(1)
      by (auto simp: is_dec_det_def)
qed

lemma ex_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x \<in> X.  f x = Max (f ` X)"
  by (metis (mono_tags, opaque_lifting) Max_in empty_is_image finite_imageI imageE)

lemma fin_A_imp_opt_pol:
  assumes "\<And>s. finite (A s)"
  shows "\<exists>p\<in>\<Pi>\<^sub>M\<^sub>D. \<forall>s. \<nu>N (mk_markovian_det p) s = \<nu>N_opt s"
  using A_ne assms \<nu>N_has_opt_pol
  by (fastforce simp: cSup_eq_Max intro!: ex_Max)

section \<open>Backward Induction\<close>

function bw_ind_aux where
  "bw_ind_aux n s = (
    if n = N then r_fin s else
    if n > N then 0 else
      \<Squnion>a \<in> A s. (r (s,a) +
        measure_pmf.expectation (K (s,a)) (\<lambda>s'. bw_ind_aux (Suc n) s'))) "
  by auto

termination
  by (relation "Wellfounded.measure (\<lambda>(h,s). N - h)") auto

lemmas bw_ind_aux.simps[simp del]

lemma bw_ind_aux_eq: "bw_ind_aux (length h) s = \<nu>N_opt_eqn h s"
  by (induction h s rule: \<nu>N_opt_eqn.induct)
    (auto simp: bw_ind_aux.simps \<nu>N_opt_eqn.simps split: if_splits intro!: Bochner_Integration.integral_cong SUP_cong)

fun bw_ind_aux' where
  "bw_ind_aux' (Suc n) m = (
    let m' = (\<lambda>i s.
      if i = n
      then (\<Squnion>a \<in> A s. (r (s,a) + measure_pmf.expectation (K (s,a)) (m (Suc n))))
      else m i s) in
    bw_ind_aux' n m')" |
  "bw_ind_aux' 0 m = m"

definition "bw_ind = bw_ind_aux' N (\<lambda>i s. if i = N then r_fin s else 0)"

lemma bw_ind_aux'_const[simp]:
  assumes "i \<ge> n"
  shows "bw_ind_aux' n m i = m i"
  using assms
proof (induction n arbitrary: m i)
  case 0
  then show ?case by (auto simp: bw_ind_aux'.simps)
next
  case (Suc n)
  then show ?case
    by auto
qed

lemma bw_ind_aux'_indep:
  assumes "i < n" and
    "\<And>j. j > i \<Longrightarrow> m j = m' j"
  shows "bw_ind_aux' n m i s = bw_ind_aux' n m' i s"
  using assms
proof (induction n arbitrary: m i m')
  case 0
  then show ?case
    by fastforce
next
  case (Suc n)
  show ?case
  proof (cases "i < n")
    case True
    then show ?thesis
      by (auto intro!: Suc(1) ext simp: Suc(2,3))
  next
    case False
    then show ?thesis
      using Suc.prems(1) less_Suc_eq
      by (auto simp: Suc)
  qed
  qed

lemma bw_ind_aux'_simps': "i < n \<Longrightarrow> bw_ind_aux' n m i s = (\<Squnion>a \<in> A s. (r (s,a) + measure_pmf.expectation (K (s,a)) (bw_ind_aux'  n m (Suc i))))"
proof (induction n arbitrary: m i s)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "bw_ind_aux' (Suc n) m i s = bw_ind_aux' n (\<lambda>i s. if i = n then \<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) (m (Suc n)) else m i s) i s"
    by auto
  also have "\<dots> = (\<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) ((bw_ind_aux' (Suc n) m (Suc i))))"
    using Suc.prems le_less_Suc_eq
    by (cases "n \<le> i") (auto simp: Suc.IH bw_ind_aux'_const)
  finally show ?case.
qed

lemma bw_ind_correct: "n \<le> N \<Longrightarrow> bw_ind n = bw_ind_aux n"
  unfolding bw_ind_def
proof (induction "N - n" arbitrary: n)
  case 0
  show ?case
    using 0
    by (subst bw_ind_aux.simps) (auto)
next
  case (Suc x)
  thus ?case
    by (auto simp: bw_ind_aux'_simps' bw_ind_aux.simps intro!: ext)
qed

definition "bw_ind_pol_gen (d :: 'a set \<Rightarrow> 'a) n s = (
  if n \<ge> N then d (A s)
  else
    d ({a . is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) a}))"

lemma bw_ind_pol_is_arg_max:
  assumes "\<And>X. X \<noteq> {} \<Longrightarrow> d X \<in> X" "\<And>s. finite (A s)"
  shows "is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) (d ({a . is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) a}))"
proof -
  let ?s = "{a. is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) a}"
  have \<open>d ?s \<in> ?s\<close>
    using assms(1)[of " {a. is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) a}"]
    using  finite_is_arg_max A_ne assms
    by (auto simp add: finite_is_arg_max)
  thus ?thesis
    by auto
qed

lemma bw_ind_pol_gen:
  assumes "\<And>X. X \<noteq> {} \<Longrightarrow> d X \<in> X" "\<And>s. finite (A s)"
  shows "bw_ind_pol_gen d \<in> \<Pi>\<^sub>M\<^sub>D"
proof -
  have ***:"X \<noteq> {} \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> d X \<in> Y" for X Y
    using assms
    by auto
  have "\<exists>a. is_arg_max (\<lambda>a. r (s, a) + measure_pmf.expectation (K (s, a)) (bw_ind_aux (Suc n))) (\<lambda>a. a \<in> A s) a" for n s
    using finite_is_arg_max[OF assms(2) A_ne]
    by auto
  thus ?thesis
    unfolding bw_ind_pol_gen_def is_dec_det_def
    by (force intro!: ***)
qed

lemma
  assumes "\<And>X. X \<noteq> {} \<Longrightarrow> d X \<in> X"  "\<And>s. finite (A s)" "length h \<le> N"
  shows "\<nu>N_eval (mk_markovian_det (bw_ind_pol_gen d)) h s = \<nu>N_eval_opt h s"
proof -
  have "(\<And>h s. length h < N \<Longrightarrow>
            (\<Squnion>a\<in>A s. r (s, a) + measure_pmf.expectation (K (s, a)) (\<nu>N_opt_eqn (h @ [(s, a)])))
            \<le> r (s, bw_ind_pol_gen d (length h) s) +
               measure_pmf.expectation (K (s, bw_ind_pol_gen d (length h) s))
                (\<nu>N_opt_eqn (h @ [(s, bw_ind_pol_gen d (length h) s)])))"
    using A_ne bw_ind_pol_is_arg_max[OF assms(1,2)]
    unfolding bw_ind_aux_eq[symmetric]
    by (auto intro!: cSUP_least simp: bw_ind_pol_gen_def)
  hence "length h \<le> N \<Longrightarrow> \<nu>N_opt_eqn h s \<le> \<nu>N_eval (mk_markovian_det (bw_ind_pol_gen d)) h s" for h s
    using assms bw_ind_pol_gen thm_4_3_4[of 0 "bw_ind_pol_gen d", simplified]
    by auto
  thus ?thesis
    using \<nu>N_opt_eq \<nu>N_eval_le_opt assms bw_ind_pol_gen mk_markovian_det_preserves
    by (auto intro!: antisym)
qed

lemma bw_ind_aux'_eq: "n \<le> N \<Longrightarrow> bw_ind_aux' N (\<lambda>i s. if i = N then r_fin s else 0) n = bw_ind_aux n"
  using bw_ind_def bw_ind_correct by presburger
end

end


(*<*)
(*
   Title:  Theory ListExtras.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2014
*)
(*>*)
section \<open>Auxiliary Theory ListExtras.thy\<close>

theory ListExtras
imports Main
begin

definition
  disjoint :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
 "disjoint x y \<equiv>  (set x) \<inter> (set y) = {}"

primrec
  mem ::  "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infixr "mem" 65)
where
  "x mem [] = False" |
  "x mem (y # l) = ((x = y) \<or> (x mem l))"

definition
  memS ::  "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
 "memS x l  \<equiv>  x \<in> (set l)"

lemma mem_memS_eq:  "x mem l \<equiv> memS x l"
proof (induct l)
  case Nil
  from this show ?case by (simp add: memS_def)
next
    fix a la case (Cons a la)
    from Cons show ?case by (simp add: memS_def)
 qed

lemma mem_set_1:
assumes "a mem l"
shows "a \<in> set l"
using assms by (metis memS_def mem_memS_eq)

lemma mem_set_2:
assumes "a \<in> set l"
shows "a mem l"
using assms by (metis (full_types) memS_def mem_memS_eq)

lemma set_inter_mem:
assumes "x mem l1"
       and "x mem l2"
shows "set l1 \<inter> set l2 \<noteq> {}"
using assms  by (metis IntI empty_iff mem_set_1)

lemma mem_notdisjoint:
assumes "x mem l1"
       and "x mem l2"
shows "\<not> disjoint l1 l2"
using assms by (metis disjoint_def set_inter_mem)

lemma mem_notdisjoint2:
assumes h1:"disjoint (schedule A) (schedule B)"
       and h2:"x mem schedule A"
shows "\<not> x mem schedule B"
proof -
  { assume " x mem schedule B"
     from h2 and this have "\<not>  disjoint (schedule A) (schedule B)"
       by (simp add: mem_notdisjoint)
    from h1 and this have "False" by simp
   } then have "\<not> x mem schedule B" by blast
  then show ?thesis by simp
qed

lemma list_length_hint1:
assumes "l \<noteq> []"
shows    "0 < length l"
using assms by simp

lemma list_length_hint1a:
assumes "l \<noteq> []"
shows    "0 < length l"
using assms by simp

lemma list_length_hint2:
assumes "length x  = Suc 0"
shows    "[hd x] = x"
using assms
by (metis Zero_neq_Suc list.sel(1) length_Suc_conv neq_Nil_conv)

lemma list_length_hint2a:
assumes "length l = Suc 0"
shows    "tl l = []"
using assms
by (metis list_length_hint2 list.sel(3))

lemma list_length_hint3:
assumes "length l = Suc 0"
shows    "l \<noteq> []"
using assms
by (metis Zero_neq_Suc list.size(3))

lemma list_length_hint4:
assumes "length x \<le> Suc 0"
       and "x \<noteq> []"
shows "length x = Suc 0"
using assms
by (metis le_0_eq le_Suc_eq length_greater_0_conv less_numeral_extra(3))

lemma length_nonempty:
assumes "x \<noteq> []"
shows    "Suc 0 \<le> length x"
using assms
by (metis length_greater_0_conv less_eq_Suc_le)

lemma last_nth_length:
assumes "x \<noteq> []"
shows    "x ! ((length x) - Suc 0) = last x"
using assms
by (metis One_nat_def last_conv_nth)

lemma list_nth_append0:
assumes "i < length x"
shows    "x ! i = (x @ z) ! i"
using assms
by (metis nth_append)

lemma list_nth_append4:
assumes "i < Suc (length x + length y)"
       and "\<not> i - Suc (length x) < Suc (length y)"
shows "False"
using assms  by arith

lemma list_nth_append5:
assumes "i - length x < Suc (length y)"
       and "\<not> i - Suc (length x) < Suc (length y)"
shows "\<not>  i < Suc (length x + length y)"
using assms  by arith

lemma list_nth_append6:
assumes "\<not> i - length x < Suc (length y)"
       and "\<not> i - Suc (length x) < Suc (length y)"
shows "\<not> i < Suc (length x + length y)"
using assms by arith

lemma list_nth_append6a:
assumes "i < Suc (length x + length y)"
       and "\<not> i - length x < Suc (length y)"
shows "False"
using assms by arith

lemma list_nth_append7:
assumes "i - length x < Suc (length y)"
       and "i - Suc (length x) < Suc (length y)"
shows    "i < Suc (Suc (length x + length y))"
using assms  by arith

lemma list_nth_append8:
assumes "\<not> i < Suc (length x + length y)"
       and "i < Suc (Suc (length x + length y))"
shows     "i = Suc (length x + length y)"
using assms  by arith

lemma list_nth_append9:
assumes "i - Suc (length x) < Suc (length y)"
shows    "i < Suc (Suc (length x + length y))"
using assms by arith

lemma list_nth_append10:
assumes "\<not> i < Suc (length x)"
       and "\<not> i - Suc (length x) < Suc (length y)"
shows    "\<not> i < Suc (Suc (length x + length y))"
using assms by arith

end


(*
  File:    Elementary_Prime_Bounds.thy
  Author:  Manuel Eberl, TU München

  Elementary bounds for the prime-counting function \<pi>(x) and the "n-th prime" function p_n
*)
section \<open>Elementary bounds on $\pi(x)$ and $p_n$\<close>
theory Elementary_Prime_Bounds
imports
  Prime_Number_Theorem.Prime_Counting_Functions
  Prime_Distribution_Elementary_Library
  More_Dirichlet_Misc
begin

text \<open>
  In this section, we will follow Apostol and give elementary proofs of Chebyshev-type
  lower and upper bounds for $\pi(x)$, i.\,e.\ $c_1 x/\ln x < \pi(x) < c_2 x/\ln x$. From
  this, similar bounds for $p_n$ follow as easy corollaries.
\<close>

(* TODO: Move stuff from Prime_Number_Theorem here *)

subsection \<open>Preliminary lemmas\<close>

text \<open>
  The following two estimates relating the central Binomial coefficient to powers
  of 2 and 4 form the starting point for Apostol's elementary bounds for $\pi(x)$:
\<close>
lemma twopow_le_central_binomial: "2 ^ n \<le> ((2 * n) choose n)"
proof -
  have "2 ^ n * fact n ^ 2 \<le> (fact (2 * n) :: nat)"
  proof (induction n)
    case (Suc n)
    have "(fact (2 * Suc n) :: nat) = (2 * n + 1) * (2 * n + 2) * fact (2 * n)"
      by (simp add: algebra_simps)

    have "2 ^ Suc n * fact (Suc n) ^ 2 = 2 ^ n * fact n ^ 2 * 2 * (n + 1) ^ 2"
      by (simp add: algebra_simps power2_eq_square)
    also have "\<dots> \<le> fact (2 * n) * 2 * (n + 1) ^ 2"
      by (intro mult_right_mono Suc.IH) auto
    also have "\<dots> = fact (2 * n) * (2 * (n + 1) ^ 2)"
      by (simp add: mult_ac)
    also have "\<dots> \<le> fact (2 * n) * ((2 * n + 1) * (2 * n + 2))"
      by (intro mult_left_mono) (auto simp: power2_eq_square)
    also have "\<dots> = fact (2 * Suc n)"
      by (simp add: algebra_simps)
    finally show ?case .
  qed simp_all
  also have "\<dots> = (2 * n choose n) * fact n ^ 2"
    using binomial_fact_lemma[of n "2 * n"] by (simp add: power2_eq_square mult_ac)
  finally show ?thesis by simp
qed

lemma fourpow_gt_central_binomial:
  assumes "n > 0"
  shows   "4 ^ n > ((2 * n) choose n)"
proof -
  have "(\<Sum>i\<in>{..2*n}-{n}. ((2 * n) choose i)) > 0"
    using assms by (intro sum_pos) (auto simp: subset_iff)
  hence "((2 * n) choose n) < (\<Sum>i\<in>{..2*n}-{n}. ((2 * n) choose i)) + ((2 * n) choose n)"
    by simp
  also have "\<dots> = (\<Sum>i \<in> insert n ({..2*n} - {n}). ((2 * n) choose i))"
    by (subst sum.insert) auto
  also have "insert n ({..2*n} - {n}) = {..2*n}" by auto
  also have "(\<Sum>i\<le>2*n. ((2 * n) choose i)) = (1 + 1) ^ (2 * n)"
    by (subst binomial) simp_all
  also have "\<dots> = 4 ^ n"
    by (subst power_mult) (simp add: eval_nat_numeral)
  finally show ?thesis .
qed

subsection \<open>Lower bound for $\pi(x)$\<close>

context
  includes prime_counting_notation
  fixes S :: "nat \<Rightarrow> nat \<Rightarrow> int"
  defines "S \<equiv> (\<lambda>n p. (\<Sum>m\<in>{0<..nat \<lfloor>log p (2*n)\<rfloor>}. \<lfloor>2*n/p^m\<rfloor> - 2 * \<lfloor>n/p^m\<rfloor>))"
begin

text \<open>
  We now first prove the bound $\pi(x) \geq \frac{1}{6} x/\ln x$ for $x\geq 2$.
  The constant could probably be improved for starting points greater than 2; this
  is true for most of the constants in this section.

  The first step is to show a slightly stronger bound for even numbers, where the
  constant is $\frac{1}{2}\ln 2 \approx 0.347$:
\<close>
lemma
  fixes n :: nat
  assumes n: "n \<ge> 1"
  shows   \<pi>_bounds_aux: "ln (fact (2 * n)) - 2 * ln (fact n) =
                           prime_sum_upto (\<lambda>p. S n p * ln p) (2 * n)"
  and     \<pi>_lower_bound_ge_strong: "\<pi> (2 * n) \<ge> ln 2 / 2 * (2 * n) / ln (2 * n)"
proof -
  define L :: "real \<Rightarrow> nat \<Rightarrow> nat" where "L = (\<lambda>x p. legendre_aux x p)"
  have "ln (fact (2 * n)) - 2 * ln (fact n) = sum_upto ln (2 * n) - 2 * sum_upto ln n"
    by (simp add: ln_fact_conv_sum_upto)
  also have "\<dots> = prime_sum_upto (\<lambda>p. L (2 * n) p * ln p) (2 * n) -
                    2 * prime_sum_upto (\<lambda>p. L n p * ln p) n"
    by (subst (1 2) legendre_identity) (auto simp: L_def)
  also have "prime_sum_upto (\<lambda>p. L n p * ln p) n = prime_sum_upto (\<lambda>p. L n p * ln p) (2 * n)"
    unfolding prime_sum_upto_altdef2
    by (intro sum.mono_neutral_left[OF finite_subset[of _ "{..2*n}"]])
       (auto dest: prime_gt_0_nat legendre_aux_posD
             simp: legendre_aux_eq_0 L_def le_nat_iff le_floor_iff)
  also have "prime_sum_upto (\<lambda>p. L (2*n) p * ln p) (2*n) -
                 2 * prime_sum_upto (\<lambda>p. L n p * ln p) (2 * n) =
               prime_sum_upto (\<lambda>p. (real (L (2*n) p) - 2 * real (L n p)) * ln p) (2 * n)"
    by (simp add: ring_distribs sum_subtractf sum_distrib_left mult.assoc prime_sum_upto_def)
  also have "\<dots> = prime_sum_upto (\<lambda>p. of_int (S n p) * ln p) (2*n)"
    unfolding prime_sum_upto_def
  proof (intro sum.cong refl, goal_cases)
    case (1 p)
    define ub where "ub = nat \<lfloor>log p (2*n)\<rfloor>"
    from 1 have p: "prime p" "p > 1" "p \<le> 2 * n"
      using prime_gt_1_nat[of p] by auto
    have "L (2 * n) p = (\<Sum>m\<in>{0<..ub}. nat \<lfloor>2*n/p^m\<rfloor>)"
      unfolding L_def legendre_aux_altdef1 using p 1 by (auto simp: ub_def)
    moreover have "L n p = (\<Sum>m\<in>{0<..ub}. nat \<lfloor>n/p^m\<rfloor>)" unfolding L_def
    proof (intro legendre_aux_altdef2)
      have "real n = real p powr log p n"
        using n p by simp
      also have "log (real p) 2 > 0" using p by auto
      hence "log p n < 1 + of_int \<lfloor>log p 2 + log p n\<rfloor>" by linarith
      hence "real p powr log p n < real p powr Suc ub"
        unfolding ub_def using n p by (intro powr_less_mono) (auto simp: log_mult)
      also have "\<dots> = p ^ Suc ub"
        using p by (subst powr_realpow) auto
      finally show "real n < real p ^ Suc ub" by simp
    qed (use n p in auto)
    ultimately have "real (L (2 * n) p) - 2 * real (L n p) =
                       (\<Sum>m\<in>{0<..ub}. real (nat \<lfloor>2*n/p^m\<rfloor>) - 2 * real (nat \<lfloor>n/p^m\<rfloor>))"
      by (simp add: sum_subtractf sum_distrib_left)
    also have "\<dots> = of_int (\<Sum>m\<in>{0<..ub}. \<lfloor>2*n/p^m\<rfloor> - 2 * \<lfloor>n/p^m\<rfloor>)"
      unfolding of_int_sum by (intro sum.cong) auto
    finally show ?case by (simp add: ub_def S_def)
  qed
  finally show eq: "ln (fact (2 * n)) - 2 * ln (fact n) =
                      prime_sum_upto (\<lambda>p. S n p * ln p) (2 * n)" .

  have S_nonneg: "S n p \<ge> 0" for p
    unfolding S_def by (intro sum_nonneg) linarith
  have S_le: "S n p \<le> \<lfloor>log p (2*n)\<rfloor>" if "prime p" for p
  proof -
    have "S n p \<le> (\<Sum>m\<in>{0<..nat \<lfloor>log p (2*n)\<rfloor>}. 1)"
      unfolding S_def of_nat_mult of_nat_numeral by (intro sum_mono) linarith
    thus ?thesis using prime_gt_1_nat[of p] that n by auto
  qed

  have "n * ln 2 = ln (real (2 ^ n))"
    by (simp add: ln_realpow)
  also have "\<dots> \<le> ln (real ((2*n) choose n))"
    using twopow_le_central_binomial[of n]
    by (subst ln_le_cancel_iff; (unfold of_nat_le_iff)?) auto
  also have "\<dots> = ln (fact (2 * n)) - 2 * ln (fact n)"
    by (simp add: binomial_fact ln_div ln_mult)
  also have "\<dots> = prime_sum_upto (\<lambda>p. S n p * ln p) (2 * n)"
    by (fact eq)
  also have "\<dots> \<le> prime_sum_upto (\<lambda>p. \<lfloor>log p (2*n)\<rfloor> * ln p) (2 * n)"
    unfolding prime_sum_upto_def using S_le
    by (intro sum_mono mult_right_mono) (auto dest: prime_gt_0_nat)
  also have "\<dots> \<le> prime_sum_upto (\<lambda>p. ln (2 * n)) (2 * n)"
    unfolding prime_sum_upto_def
  proof (intro sum_mono)
    fix p assume "p \<in> {p. prime p \<and> real p \<le> real (2 * n)}"
    hence p: "p > 1" using prime_gt_1_nat[of p] by auto
    have "real_of_int \<lfloor>log p (2 * n)\<rfloor> = real_of_int \<lfloor>ln (2 * n) / ln p\<rfloor>"
      using p n by (simp add: log_def ln_mult)
    also have "\<dots> \<le> ln (2 * n) / ln p"
      by linarith
    also have "\<dots> * ln p = ln (2 * n)"
      using p by (simp add: field_simps)
    finally show "real_of_int \<lfloor>log p (2 * n)\<rfloor> * ln p \<le> ln (2 * n)"
      using p by simp
  qed
  also have "\<dots> = ln (2 * n) * \<pi> (2 * n)"
    by (simp add: \<pi>_def prime_sum_upto_def)
  finally show "\<pi> (2 * n) \<ge> (ln 2 / 2) * (2 * n) / ln (2 * n)"
    using n by (simp add: field_simps)
qed

lemma ln_2_ge_56_81: "ln 2 \<ge> (56 / 81 :: real)"
  using ln_approx_bounds[of 2 2, simplified, simplified eval_nat_numeral, simplified] by simp

text \<open>
  The bound for any real number $x\geq 2$ follows fairly easily, although some ugly
  accounting for error terms has to be done.
\<close>
theorem \<pi>_lower_bound:
  fixes x :: real
  assumes x: "x \<ge> 2"
  shows   "\<pi> x > (1 / 6) * (x / ln x)"
proof (cases "even (nat \<lfloor>x\<rfloor>)")
  case True
  define n where "n = nat \<lfloor>x\<rfloor>"
  from True assms have n: "n \<ge> 2" "even n"
    by (auto simp: n_def le_nat_iff le_floor_iff)
  have "(1 / 6) * (x / ln x) < (ln 2 / 4) * (x / ln x)"
    using ln_2_ge_56_81 x by (intro mult_strict_right_mono) auto
  also have "ln 2 / 4 * (x / ln x) = (1 / 2) * (ln 2 / 2 * x / ln x)"
    by simp
  also have "\<dots> \<le> (1 - 1 / x) * (ln 2 / 2 * x / ln x)"
    by (intro mult_right_mono) (use assms in \<open>auto simp: field_simps\<close>)
  also have "(1 - 1 / x) * (ln 2 / 2 * x / ln x) = ln 2 / 2 * (x - 1) / ln x"
    using assms by (simp add: field_simps)
  also have "ln 2 / 2 * (x - 1) / ln x \<le> ln 2 / 2 * n / ln n"
    using x by (intro frac_le mult_mono mult_nonneg_nonneg) (auto simp: n_def)
  also have "ln 2 / 2 * n / ln n \<le> \<pi> n"
    using \<pi>_lower_bound_ge_strong[of "n div 2"] \<open>even n\<close> n by simp
  also have "\<pi> n = \<pi> x" by (simp add: n_def)
  finally show ?thesis .
next
  case False
  define n where "n = nat \<lfloor>x\<rfloor>"
  from False assms have n: "n \<ge> 2" "odd n"
    by (auto simp: n_def le_nat_iff le_floor_iff)
  then obtain k where [simp]: "n = 2 * k + 1"
    by (auto elim!: oddE)
  from n have k: "k > 0" by simp

  from k have "3 \<le> real n" by simp
  also have "real n \<le> x" unfolding n_def using x by linarith
  finally have "x \<ge> 3" .

  have "(1 / 6) * (x / ln x) = 1 / 6 * x / ln x"
    using x by (simp add: field_simps)
  also have "1 / 6 * x / ln x < ln 2 / 2 * (2 * k) / ln (2 * k)"
  proof (intro frac_less)
    have "x < real n + 1" unfolding n_def by linarith
    hence "1 / 6 * x < 1 / 6 * (n + 1)" by simp
    also {
      have *: "(3 * ln 2 - 1 :: real) \<ge> 1"
        using ln_2_ge_56_81 by simp
      hence "1 / (3 * ln 2 - 1 :: real) \<le> 1" by simp
      also have "1 \<le> real k" using k by simp
      finally have "1 / 6 * (n + 1) \<le> ln 2 / 2 * real (2 * k)"
        using * by (simp add: field_simps)
    }
    finally show "1 / 6 * x < ln 2 / 2 * real (2 * k)" .
  next
    have "real (2 * k) \<le> real n" by simp
    also have "\<dots> \<le> x" using x unfolding n_def by linarith
    finally show "ln (real (2 * k)) \<le> ln x" using k by simp
  qed (use k x in auto)
  also have "ln 2 / 2 * (2 * k) / ln (2 * k) \<le> \<pi> (2 * k)"
    by (rule \<pi>_lower_bound_ge_strong) (use \<open>k > 0\<close> in auto)
  also have "\<pi> (2 * k) \<le> \<pi> n"
    by (rule \<pi>_mono) auto
  also have "\<dots> = \<pi> x" unfolding n_def by simp
  finally show ?thesis .
qed

lemma \<pi>_at_top: "filterlim primes_pi at_top at_top"
proof (rule filterlim_at_top_mono)
  show "eventually (\<lambda>x. primes_pi x \<ge> 1 / 6 * (x / ln x)) at_top"
    using eventually_gt_at_top[of 2] by eventually_elim (intro less_imp_le \<pi>_lower_bound)
qed real_asymp

subsection \<open>Upper bound for $\vartheta(x)$\<close>

text \<open>
  In this section, we prove a linear upper bound for $\vartheta$. This is somewhat unnecessary
  because we already have a considerably better bound on $\vartheta(x)$ using a proof that has
  roughly the same complexity as this one and also only uses elementary means. Nevertheless,
  here is the proof from Apostol's book; it is quite nice and it would be a shame not to
  formalise it.

  The idea is to first show a bound for $\vartheta(2n)-\vartheta(n)$ and then deduce one for
  $\vartheta(2^n)$ from this by telescoping, which then yields one for general $x$ by
  monotonicity.
\<close>
lemma \<theta>_double_less:
  fixes n :: nat
  assumes n: "n > 0"
  shows "\<theta> (2 * real n) - \<theta> (real n) < real n * ln 4"
proof (cases "n \<ge> 2")
  case False
  with assms have "n = 1" by force
  moreover have "\<theta> 2 = ln 2" by (simp add: eval_\<theta>)
  ultimately show ?thesis by auto
next
  define P where "P = (\<lambda>n::nat. {p\<in>{0<..n}. prime p})"
  have \<theta>_eq: "\<theta> n = (\<Sum>p\<in>P n. ln p)" for n
    unfolding \<theta>_def prime_sum_upto_def
    by (intro sum.cong) (auto simp: P_def dest: prime_gt_0_nat)

  have "\<theta> (2 * n) - \<theta> n = (\<Sum>p \<in> P (2*n) - P n. ln p)"
    unfolding \<theta>_eq by (rule Groups_Big.sum_diff [symmetric]) (auto simp: P_def)

  also have "(\<Sum>p\<in>P (2*n) - P n. ln p) =
          (\<Sum>p\<in>P (2*n) - P n. (\<lfloor>2*n/p\<rfloor> - 2 * \<lfloor>n/p\<rfloor>) * ln p)"
  proof (intro sum.cong refl)
    fix p assume p: "p \<in> P (2*n) - P n"
    hence *: "real n / real p < 1" "real n / real p \<ge> 1 / 2" by (auto simp: P_def)
    from * have "\<lfloor>real n / real p\<rfloor> = 0" by linarith
    moreover from * have "\<lfloor>2 * real n / real p\<rfloor> = 1"
      by linarith
    ultimately show "ln p = (\<lfloor>2*n/p\<rfloor> - 2 * \<lfloor>n/p\<rfloor>) * ln p"
      by simp
  qed

  also have "(\<Sum>p\<in>P (2*n) - P n. (\<lfloor>2*n/p\<rfloor> - 2 * \<lfloor>n/p\<rfloor>) * ln p) \<le>
          (\<Sum>p\<in>P (2*n). (\<lfloor>2*n/p\<rfloor> - 2 * \<lfloor>n/p\<rfloor>) * ln p)"
  proof (intro sum_mono2)
    fix p assume p: "p \<in> P (2 * n) - (P (2 * n) - P n)"
    have "2 * \<lfloor>real n / real p\<rfloor> \<le> \<lfloor>2 * (real n / real p)\<rfloor>"
      by linarith
    thus "0 \<le> real_of_int (\<lfloor>real (2 * n) / real p\<rfloor> - 2 * \<lfloor>real n / real p\<rfloor>) * ln (real p)"
      using p by (intro mult_nonneg_nonneg) (auto simp: P_def)
  qed (auto simp: P_def)

  also have *: "2 * real_of_int \<lfloor>real n / real p ^ m\<rfloor> \<le> 2 * real n / real p ^ m" for p m
    by linarith
  have "(\<Sum>m\<in>{1}. \<lfloor>2 * real n / real p ^ m\<rfloor> - 2 * \<lfloor>n / real p^m\<rfloor>) \<le> S n p"
    if "prime p" "p \<le> 2 * n" for p :: nat
    unfolding S_def using prime_gt_1_nat[OF that(1)] that(2) n *[of p]
    by (intro sum_mono2) (auto dest: prime_gt_1_nat simp: le_nat_iff le_floor_iff)
  hence "(\<Sum>p\<in>P (2*n). (\<Sum>m\<in>{1}. \<lfloor>2*n/p^m\<rfloor> - 2 * \<lfloor>n/p^m\<rfloor>) * ln p) \<le> (\<Sum>p\<in>P (2*n). S n p * ln p)"
    by (intro sum_mono mult_right_mono; (unfold of_int_le_iff)?)
       (auto dest: prime_gt_1_nat simp: P_def)
  hence "(\<Sum>p\<in>P (2*n). (\<lfloor>2*n/p\<rfloor> - 2 * \<lfloor>n/p\<rfloor>) * ln p) \<le> (\<Sum>p\<in>P (2*n). S n p * ln p)"
    by simp

  also have "(\<Sum>p \<in> P (2*n). S n p * ln p) = prime_sum_upto (\<lambda>p. S n p * ln p) (2 * n)"
    unfolding P_def prime_sum_upto_def by (intro sum.cong) (auto simp: P_def dest: prime_gt_0_nat)
  also have "\<dots> = ln (fact (2 * n)) - 2 * ln (fact n)"
    by (rule \<pi>_bounds_aux [symmetric]) (use n in auto)
  also have "\<dots> = ln (real ((2*n) choose n))"
    by (simp add: binomial_fact ln_div ln_mult)
  also have "\<dots> < ln (real (4 ^ n))"
    by (subst ln_less_cancel_iff; (unfold of_nat_le_iff)?)
       (use fourpow_gt_central_binomial[of n] n in auto)
  also have "\<dots> = n * ln 4"
    by (simp add: ln_realpow)
  finally show ?thesis by simp
qed

lemma \<theta>_twopow_less: "\<theta> (2 ^ r) < 2 ^ (r + 1) * ln 2"
proof -
  have \<theta>_twopow_diff: "\<theta> (2 ^ Suc k) - \<theta> (2 ^ k) < 2 ^ Suc k * ln 2" for k
    using \<theta>_double_less[of "2 ^ k"] ln_realpow[of 2 2] by simp
  show "\<theta> (2 ^ r) < 2 ^ (r + 1) * ln 2"
  proof (cases "r > 0")
    case True
    have "(\<Sum>k<r. \<theta> (2 ^ Suc k) - \<theta> (2 ^ k)) < (\<Sum>k<r. 2 ^ Suc k * ln 2)"
      by (intro sum_strict_mono \<theta>_twopow_diff) (use \<open>r > 0\<close> in auto)
    also have "(\<Sum>k<r. \<theta> (2 ^ Suc k) - \<theta> (2 ^ k)) = \<theta> (2 ^ r)"
      by (subst sum_lessThan_telescope) auto
    also have "(\<Sum>k<r. 2 ^ Suc k * ln 2 :: real) = (\<Sum>k<r. 2 ^ k) * 2 * ln 2"
      by (simp add: sum_distrib_right sum_distrib_left mult_ac)
    also have "(\<Sum>k<r. 2 ^ k :: real) = 2 ^ r - 1"
      using geometric_sum[of "2 :: real"] by simp
    also have "\<dots> \<le> 2 ^ r" by simp
    finally show "\<theta> (2 ^ r) < 2 ^ (r + 1) * ln 2"
      by simp
  qed auto
qed

theorem \<theta>_upper_bound_weak:
  fixes n :: nat
  assumes n: "n > 0"
  shows   "\<theta> n < 4 * ln 2 * n"
proof -
  define r where "r = Discrete.log n"
  have "\<theta> n \<le> \<theta> (real (2 ^ Suc r))"
    unfolding r_def using log_exp2_ge[of n] by (intro \<theta>_mono, unfold of_nat_le_iff) auto
  also have "\<dots> < 4 * ln 2 * real (2 ^ r)"
    using \<theta>_twopow_less[of "r + 1"] by (simp add: mult_ac)
  also have "\<dots> \<le> 4 * ln 2 * real n" unfolding r_def
    by (intro mult_left_mono, unfold of_nat_le_iff, intro log_exp2_le) (use n in auto)
  finally show "\<theta> n < 4 * ln 2 * n" by simp
qed

subsection \<open>Upper bound for $\pi(x)$\<close>

text \<open>
  We use our upper bound for $\vartheta(x)$ (the strong one, not the one from the previous
  section) to derive an upper bound for $\pi(x)$.

  As a first step, we show the following lemma about the global maximum of the function
  $\ln x / x^c$ for $c > 0$:
\<close>
lemma \<pi>_upper_bound_aux:
  fixes c :: real
  assumes "c > 0"
  defines "f \<equiv> (\<lambda>x. x powr (-c) * ln x)"
  assumes x: "x > 0"
  shows "f x \<le> 1 / (c * exp 1)"
proof -
  define f' where "f' = (\<lambda>x. x powr (-c - 1) * (1 - c * ln x))"
  define z where "z = exp (1 / c)"
  have "z > 0" by (simp add: z_def)
  have deriv: "(f has_real_derivative f' t) (at t)" if "t > 0" for t
    unfolding f_def f'_def using that
    by (auto intro!: derivative_eq_intros simp: field_simps powr_diff powr_minus)
  have [simp]: "f z = 1 / (c * exp 1)"
    by (simp add: z_def f_def powr_def exp_minus field_simps)

  show ?thesis
  proof (cases x z rule: linorder_cases)
    assume x: "x < z"
    from x assms have t: "\<exists>t. t > x \<and> t < z \<and> f z - f x = (z - x) * f' t"
      by (intro MVT2 deriv) auto
    then obtain t where t: "t > x" "t < z" "f z - f x = (z - x) * f' t"
      by blast
    hence "ln t < ln z" using assms by simp
    also have "ln z = 1 / c" by (simp add: z_def)
    finally have "0 \<le> (z - x) * f' t"
      unfolding f'_def using \<open>c > 0\<close> x
      by (intro mult_nonneg_nonneg) (auto simp: z_def field_simps)
    also from t have "\<dots> = f z - f x" by (simp add: algebra_simps)
    finally show ?thesis by simp
  next
    assume x: "x > z"
    from x assms \<open>z > 0\<close> have t: "\<exists>t. t > z \<and> t < x \<and> f x - f z = (x - z) * f' t"
      by (intro MVT2 deriv) auto
    then obtain t where t: "t > z" "t < x" "f x - f z = (x - z) * f' t"
      by blast
    hence "ln z < ln t" using \<open>z > 0\<close> assms by simp
    also have "ln z = 1 / c" by (simp add: z_def)
    finally have "0 \<le> (z - x) * f' t"
      unfolding f'_def using \<open>c > 0\<close> x
      by (intro mult_nonpos_nonpos mult_nonneg_nonpos) (auto simp: z_def field_simps)
    also from t have "\<dots> = f z - f x" by (simp add: algebra_simps)
    finally show ?thesis by simp
  qed auto
qed

text \<open>
  Following Apostol, we first show a generic bound depending on some real-valued
  parameter \<open>\<alpha>\<close>:
\<close>
lemma \<pi>_upper_bound_strong:
  fixes \<alpha> :: real and n :: nat
  assumes n: "n \<ge> 2" and \<alpha>: "\<alpha> \<in> {0<..<1}"
  shows "\<pi> n < (1 / ((1 - \<alpha>) * exp 1) + ln 4 / \<alpha>) * n / ln n"
proof -
  have "real n powr \<alpha> \<le> real n powr 1"
    using assms n by (intro powr_mono) auto
  hence n': "real n powr \<alpha> \<le> real n" using n by simp

  define P where "P = (\<lambda>x. {p. prime p \<and> real p \<le> x})"
  define Q where "Q = {p. prime p \<and> real p \<in> {n powr \<alpha><..n}}"

  have finite_P [intro]: "finite (P x)" for x
  proof (cases "x \<ge> 0")
    case True
    hence "P x \<subseteq> {..nat \<lfloor>x\<rfloor>}"
      by (auto simp: le_nat_iff le_floor_iff P_def)
    thus ?thesis by (rule finite_subset) auto
  qed (auto simp: P_def)

  have P_subset: "P x \<subseteq> P y" if "x \<le> y" for x y
    using that by (auto simp: P_def)

  have "Q = P n - P (n powr \<alpha>)" by (auto simp: Q_def P_def)
  also have "card \<dots> = card (P n) - card (P (n powr \<alpha>))"
    by (intro card_Diff_subset finite_P P_subset n')
  also have "real \<dots> = \<pi> n - \<pi> (n powr \<alpha>)"
    by (subst of_nat_diff[OF card_mono[OF _ P_subset]])
       (use n' in \<open>auto simp: \<pi>_def prime_sum_upto_def P_def\<close>)
  finally have card_Q: "real (card Q) = \<pi> n - \<pi> (n powr \<alpha>)" .

  have "(\<pi> n - \<pi> (n powr \<alpha>)) * ln (n powr \<alpha>) = (\<Sum>p\<in>Q. ln (n powr \<alpha>))"
    using card_Q by simp
  also have "\<dots> \<le> (\<Sum>p\<in>Q. ln p)"
    using n \<alpha> by (intro sum_mono, subst ln_le_cancel_iff) (auto simp: Q_def dest: prime_gt_0_nat)
  also have "\<dots> \<le> \<theta> n"
    unfolding \<theta>_def prime_sum_upto_def by (intro sum_mono2) (auto simp: Q_def dest: prime_gt_1_nat)
  also have "\<dots> < ln 4 * real n"
    by (rule \<theta>_upper_bound) (use n in auto)
  finally have ineq: "(\<pi> n - \<pi> (n powr \<alpha>)) * ln (n powr \<alpha>) < ln 4 * n" .

  with n assms have "\<pi> n < \<pi> (n powr \<alpha>) + (ln 4 / \<alpha>) * n / ln n"
    by (simp add: field_simps ln_powr
             del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
  also have "\<pi> (n powr \<alpha>) \<le> n powr \<alpha>"
    by (rule \<pi>_le_self) auto
  also have "n powr \<alpha> + ln 4 / \<alpha> * n / ln n =
               (n powr (-(1 - \<alpha>)) * ln n + ln 4 / \<alpha>) * n / ln n"
    using n \<alpha> by (simp add: field_simps powr_diff
                       del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
  also have "n powr (-(1 - \<alpha>)) * ln n \<le> 1 / ((1 - \<alpha>) * exp 1)"
    by (intro \<pi>_upper_bound_aux) (use \<alpha> n in auto)
  hence "(n powr (-(1 - \<alpha>)) * ln n + ln 4 / \<alpha>) * n / ln n \<le>
           (1 / ((1 - \<alpha>) * exp 1) + ln 4 / \<alpha>) * n / ln n"
    using n \<alpha> by (intro divide_right_mono mult_right_mono add_mono) auto
  finally show "\<pi> n < (1 / ((1 - \<alpha>) * exp 1) + ln 4 / \<alpha>) * n / ln n"
    by simp
qed

text \<open>
  The choice $\alpha := \frac{2}{3}$ then leads to the upper bound $\pi(x) < cx/\ln x$
  with $c = 3(e^{-1} + \ln 2) \approx 3.183$. This is considerably stronger than
  Apostol's bound.
\<close>
theorem \<pi>_upper_bound:
  fixes x :: real
  assumes "x \<ge> 2"
  shows   "\<pi> x < 3 * (exp (-1) + ln 2) * x / ln x"
proof (cases "x \<ge> 3")
  case False
  have "\<pi> x = \<pi> (nat \<lfloor>x\<rfloor>)" by simp
  also from False and assms have "nat \<lfloor>x\<rfloor> = 2"
    by linarith
  finally have "\<pi> x = 1" by (simp add: eval_\<pi>)
  also have "\<dots> < 3 * (exp (-1) + ln 2) * exp 1"
    by (simp add: exp_minus field_simps add_pos_pos
             del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
  also have "\<dots> \<le> 3 * (exp (-1) + ln 2) * (x / ln x)"
    using \<pi>_upper_bound_aux[of 1 x]
    by (intro mult_left_mono) (use assms in \<open>auto simp: field_simps powr_minus\<close>)
  finally show ?thesis
    using assms by (simp add: field_simps)
next
  case True
  define n where "n = nat \<lfloor>x\<rfloor>"
  from True have n: "n \<ge> 3" by (simp add: n_def le_nat_iff le_floor_iff)
  have "\<pi> x = \<pi> n"
    by (simp add: n_def)
  also have "\<pi> n < 3 * (exp (-1) + ln 2) * (n / ln n)"
    using \<pi>_upper_bound_strong[of n "2 / 3"] ln_realpow[of 2 2] n
    by (simp add: field_simps exp_minus
             del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
  also have "\<dots> \<le> 3 * (exp (-1) + ln 2) * (x / ln x)"
    using n True by (intro mult_left_mono divide_ln_mono) (auto simp: n_def)
  finally show ?thesis by (simp add: divide_simps)
qed

corollary \<pi>_upper_bound':
  fixes x :: real
  assumes "x \<ge> 2"
  shows   "\<pi> x < 443 / 139 * (x / ln x)"
proof -
  have "2.71828 \<le> 5837465777 / 2147483648 - inverse (2 ^ 32 :: real)"
    by simp
  also have "\<dots> \<le> exp (1 :: real)"
    using e_approx_32 by linarith
  finally have "exp 1 \<ge> (2.71828 :: real)" .
  hence e_m1: "exp (-1) \<le> (10^5 / 271828 :: real)" by (simp add: field_simps exp_minus)

  from assms have "\<pi> x < 3 * (exp (-1) + ln 2) * (x / ln x)"
    using \<pi>_upper_bound[of x] by (simp add: field_simps)
  also have "\<dots> \<le> 443 / 139 * (x / ln x)"
  proof (intro mult_right_mono)
    have "3 * (exp (-1) + ln 2 :: real) \<le> 3 * (10^5 / 271828 + 25 / 36)"
      using e_m1 by (intro mult_left_mono add_mono ln2_le_25_over_36)
                    (auto simp: exp_minus field_simps abs_if split: if_splits)
    also have "\<dots> \<le> 443 / 139" by simp
    finally show "3 * (exp (- 1) + ln 2 :: real) \<le> 443 / 139" by simp
  qed (use assms in auto)
  finally show ?thesis .
qed

corollary \<pi>_upper_bound'':
  fixes x :: real
  assumes "x \<ge> 2"
  shows   "\<pi> x < 4 * (x / ln x)"
  by (rule less_le_trans[OF \<pi>_upper_bound'[OF assms] mult_right_mono]) (use assms in auto)

text \<open>
  In particular, we have now shown a weak version of the Prime Number Theorem, namely
  that $\pi(x) \in \Theta(x/\ln x)$:
\<close>
lemma \<pi>_bigtheta: "\<pi> \<in> \<Theta>(\<lambda>x. x / ln x)"
proof
  have "eventually (\<lambda>x. \<bar>\<pi> x\<bar> \<le> 3 * (exp (- 1) + ln 2) * \<bar>x / ln x\<bar>) at_top"
    using eventually_ge_at_top[of 2]
    by eventually_elim (use \<pi>_upper_bound in \<open>auto intro!: less_imp_le\<close>)
  thus "\<pi> \<in> O(\<lambda>x. x / ln x)"
    by (intro bigoI[where c = "3 * (exp (- 1) + ln 2)"]) auto
next
  have "eventually (\<lambda>x. \<bar>\<pi> x\<bar> \<ge> 1 / 6 * \<bar>x / ln x\<bar>) at_top"
    using eventually_ge_at_top[of 2]
    by eventually_elim (use \<pi>_lower_bound in \<open>auto intro!: less_imp_le\<close>)
  thus "\<pi> \<in> \<Omega>(\<lambda>x. x / ln x)"
    by (intro landau_omega.bigI[where c = "1 / 6"]) auto
qed

subsection \<open>Bounds for $p_n$\<close>

text \<open>
  By some rearrangements, the lower and upper bounds for $\pi(x)$ give rise to
  analogous bounds for $p_n$:
\<close>
lemma nth_prime_lower_bound_gen:
  assumes c: "c > 0" and n: "n > 0"
  assumes "\<And>n. n \<ge> 2 \<Longrightarrow> \<pi> (real n) < (1 / c) * (real n / ln (real n))"
  shows "nth_prime (n - 1) \<ge> c * (real n * ln (real n))"
proof -
  define p where "p = nth_prime (n - 1)"
  have "p \<ge> 2"
    by (simp add: p_def nth_prime_ge_2)
  have "p \<ge> n" using nth_prime_lower_bound[of "n - 1"] by (simp add: p_def)

  have "c * (n * ln n) \<le> c * (n * ln p)"
    using n c \<open>p \<ge> n\<close> by (intro mult_left_mono) auto
  also {
    from \<open>p \<ge> 2\<close> have "\<pi> (real p) < (1 / c) * (real p / ln (real p))"
      by (rule assms)
    also from n have "\<pi> (real p) = n"
      by (simp add: p_def)
    finally have "c * (n * ln p) < p"
      using c \<open>p \<ge> 2\<close> n by (simp add: field_simps)
  }
  finally show "nth_prime (n - 1) \<ge> c * (real n * ln (real n))"
    using c n by (simp add: p_def)
qed

corollary nth_prime_lower_bound:
  "n > 0 \<Longrightarrow> nth_prime (n - 1) \<ge> (139 / 443) * (n * ln n)"
  using \<pi>_upper_bound' by (intro nth_prime_lower_bound_gen) auto

corollary nth_prime_upper_bound:
  assumes n: "n > 0"
  shows   "nth_prime (n - 1) < 12 * (n * ln n + n * ln (12 / exp 1))"
proof -
  define p where "p = nth_prime (n - 1)"
  have "p \<ge> 2"
    by (simp add: p_def nth_prime_ge_2)

  have "(1 / 6) * (p / ln p) < \<pi> p"
    by (intro \<pi>_lower_bound) (use \<open>p \<ge> 2\<close> in auto)
  also have "\<dots> = n"
    using n by (simp add: p_def)
  finally have less: "p < 6 * n * ln p"
    using \<open>p \<ge> 2\<close> by (simp add: field_simps)

  also have "ln p \<le> (2 / exp 1) * sqrt p"
    using \<pi>_upper_bound_aux[of "1 / 2" p] \<open>p \<ge> 2\<close>
    by (simp add: field_simps powr_minus powr_half_sqrt)
  finally have "sqrt p * sqrt p < 12 / exp 1 * n * sqrt p"
    using n by simp
  hence "sqrt p < 12 / exp 1 * n"
    by (subst (asm) mult_less_cancel_right) (use \<open>p \<ge> 2\<close> in auto)
  hence "ln (sqrt p) < ln (12 / exp 1 * n)"
    using n \<open>p \<ge> 2\<close> by (subst ln_less_cancel_iff) auto
  also have "ln (sqrt p) = ln p / 2"
    using \<open>p \<ge> 2\<close> by (simp add: ln_sqrt)
  also have "ln (12 / exp 1 * n) = ln n + ln (12 / exp 1)"
    using n by (simp add: ln_div ln_mult)
  finally have ln_less: "ln p \<le> 2 * ln n + 2 * ln (12 / exp 1)"
    by simp

  have "p < 6 * n * ln p" by (fact less)
  also have "\<dots> \<le> 6 * n * (2 * ln n + 2 * ln (12 / exp 1))"
    by (intro mult_left_mono ln_less) auto
  also have "\<dots> = 12 * (n * ln n + n * ln (12 / exp 1))"
    by (simp add: algebra_simps)
  finally show ?thesis unfolding p_def .
qed

text \<open>
  We can thus also conclude that $p_n \sim n \ln n$:
\<close>
corollary nth_prime_bigtheta: "nth_prime \<in> \<Theta>(\<lambda>n. n * ln n)"
proof
  have "eventually (\<lambda>n. \<bar>nth_prime n\<bar> \<le>
           12 * \<bar>(n + 1) * ln (n + 1) + (n + 1) * ln (12 / exp 1)\<bar>) at_top"
    using eventually_ge_at_top[of 2]
  proof eventually_elim
    case (elim n)
    with nth_prime_upper_bound[of "n + 1"] show ?case by (auto simp: add_ac)
  qed
  hence "nth_prime \<in> O(\<lambda>n. (n + 1) * ln (n + 1) + (n + 1) * ln (12 / exp 1))"
    by (intro bigoI[where c = 12]) auto
  also have "(\<lambda>n. (n + 1) * ln (n + 1) + (n + 1) * ln (12 / exp 1)) \<in> O(\<lambda>n::nat. n * ln n)"
    by real_asymp
  finally show "nth_prime \<in> O(\<lambda>n. n * ln n)" .
next
  have "eventually (\<lambda>n. \<bar>nth_prime n\<bar> \<ge> 139 / 443 * \<bar>(n + 1) * ln (n + 1)\<bar>) at_top"
    using eventually_ge_at_top[of 2]
  proof eventually_elim
    case (elim n)
    with nth_prime_lower_bound[of "n + 1"] show ?case by (auto simp: add_ac)
  qed
  hence "nth_prime \<in> \<Omega>(\<lambda>n::nat. real (n + 1) * ln (real n + 1))"
    by (intro landau_omega.bigI[where c = "139 / 443"]) (auto simp: add_ac)
  also have "(\<lambda>n::nat. real (n + 1) * ln (real n + 1)) \<in> \<Omega>(\<lambda>n. n * ln n)"
    by real_asymp
  finally show "nth_prime \<in> \<Omega>(\<lambda>n. n * ln n)" .
qed

end

end


(*  Title:      CCL/Wfd.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Well-founded relations in CCL\<close>

theory Wfd
imports Trancl Type Hered
begin

definition Wfd :: "[i set] \<Rightarrow> o"
  where "Wfd(R) == ALL P.(ALL x.(ALL y.<y,x> : R \<longrightarrow> y:P) \<longrightarrow> x:P) \<longrightarrow> (ALL a. a:P)"

definition wf :: "[i set] \<Rightarrow> i set"
  where "wf(R) == {x. x:R \<and> Wfd(R)}"

definition wmap :: "[i\<Rightarrow>i,i set] \<Rightarrow> i set"
  where "wmap(f,R) == {p. EX x y. p=<x,y> \<and> <f(x),f(y)> : R}"

definition lex :: "[i set,i set] => i set"      (infixl "**" 70)
  where "ra**rb == {p. EX a a' b b'. p = <<a,b>,<a',b'>> \<and> (<a,a'> : ra | (a=a' \<and> <b,b'> : rb))}"

definition NatPR :: "i set"
  where "NatPR == {p. EX x:Nat. p=<x,succ(x)>}"

definition ListPR :: "i set \<Rightarrow> i set"
  where "ListPR(A) == {p. EX h:A. EX t:List(A). p=<t,h$t>}"

lemma wfd_induct:
  assumes 1: "Wfd(R)"
    and 2: "\<And>x. ALL y. <y,x>: R \<longrightarrow> P(y) \<Longrightarrow> P(x)"
  shows "P(a)"
  apply (rule 1 [unfolded Wfd_def, rule_format, THEN CollectD])
  using 2 apply blast
  done

lemma wfd_strengthen_lemma:
  assumes 1: "\<And>x y.<x,y> : R \<Longrightarrow> Q(x)"
    and 2: "ALL x. (ALL y. <y,x> : R \<longrightarrow> y : P) \<longrightarrow> x : P"
    and 3: "\<And>x. Q(x) \<Longrightarrow> x:P"
  shows "a:P"
  apply (rule 2 [rule_format])
  using 1 3
  apply blast
  done

method_setup wfd_strengthen = \<open>
  Scan.lift Parse.embedded_inner_syntax >> (fn s => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      Rule_Insts.res_inst_tac ctxt [((("Q", 0), Position.none), s)] [] @{thm wfd_strengthen_lemma} i
        THEN assume_tac ctxt (i + 1)))
\<close>

lemma wf_anti_sym: "\<lbrakk>Wfd(r); <a,x>:r; <x,a>:r\<rbrakk> \<Longrightarrow> P"
  apply (subgoal_tac "ALL x. <a,x>:r \<longrightarrow> <x,a>:r \<longrightarrow> P")
   apply blast
  apply (erule wfd_induct)
  apply blast
  done

lemma wf_anti_refl: "\<lbrakk>Wfd(r); <a,a>: r\<rbrakk> \<Longrightarrow> P"
  apply (rule wf_anti_sym)
  apply assumption+
  done

subsection \<open>Irreflexive transitive closure\<close>

lemma trancl_wf:
  assumes 1: "Wfd(R)"
  shows "Wfd(R^+)"
  apply (unfold Wfd_def)
  apply (rule allI ballI impI)+
(*must retain the universal formula for later use!*)
  apply (rule allE, assumption)
  apply (erule mp)
  apply (rule 1 [THEN wfd_induct])
  apply (rule impI [THEN allI])
  apply (erule tranclE)
   apply blast
  apply (erule spec [THEN mp, THEN spec, THEN mp])
   apply assumption+
  done

subsection \<open>Lexicographic Ordering\<close>

lemma lexXH:
  "p : ra**rb \<longleftrightarrow> (EX a a' b b'. p = <<a,b>,<a',b'>> \<and> (<a,a'> : ra | a=a' \<and> <b,b'> : rb))"
  unfolding lex_def by blast

lemma lexI1: "<a,a'> : ra \<Longrightarrow> <<a,b>,<a',b'>> : ra**rb"
  by (blast intro!: lexXH [THEN iffD2])

lemma lexI2: "<b,b'> : rb \<Longrightarrow> <<a,b>,<a,b'>> : ra**rb"
  by (blast intro!: lexXH [THEN iffD2])

lemma lexE:
  assumes 1: "p : ra**rb"
    and 2: "\<And>a a' b b'. \<lbrakk><a,a'> : ra; p=<<a,b>,<a',b'>>\<rbrakk> \<Longrightarrow> R"
    and 3: "\<And>a b b'. \<lbrakk><b,b'> : rb; p = <<a,b>,<a,b'>>\<rbrakk> \<Longrightarrow> R"
  shows R
  apply (rule 1 [THEN lexXH [THEN iffD1], THEN exE])
  using 2 3
  apply blast
  done

lemma lex_pair: "\<lbrakk>p : r**s; \<And>a a' b b'. p = <<a,b>,<a',b'>> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>P"
  apply (erule lexE)
   apply blast+
  done

lemma lex_wf:
  assumes 1: "Wfd(R)"
    and 2: "Wfd(S)"
  shows "Wfd(R**S)"
  apply (unfold Wfd_def)
  apply safe
  apply (wfd_strengthen "\<lambda>x. EX a b. x=<a,b>")
   apply (blast elim!: lex_pair)
  apply (subgoal_tac "ALL a b.<a,b>:P")
   apply blast
  apply (rule 1 [THEN wfd_induct, THEN allI])
  apply (rule 2 [THEN wfd_induct, THEN allI]) back
  apply (fast elim!: lexE)
  done

subsection \<open>Mapping\<close>

lemma wmapXH: "p : wmap(f,r) \<longleftrightarrow> (EX x y. p=<x,y> \<and> <f(x),f(y)> : r)"
  unfolding wmap_def by blast

lemma wmapI: "<f(a),f(b)> : r \<Longrightarrow> <a,b> : wmap(f,r)"
  by (blast intro!: wmapXH [THEN iffD2])

lemma wmapE: "\<lbrakk>p : wmap(f,r); \<And>a b. \<lbrakk><f(a),f(b)> : r; p=<a,b>\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (blast dest!: wmapXH [THEN iffD1])

lemma wmap_wf:
  assumes 1: "Wfd(r)"
  shows "Wfd(wmap(f,r))"
  apply (unfold Wfd_def)
  apply clarify
  apply (subgoal_tac "ALL b. ALL a. f (a) = b \<longrightarrow> a:P")
   apply blast
  apply (rule 1 [THEN wfd_induct, THEN allI])
  apply clarify
  apply (erule spec [THEN mp])
  apply (safe elim!: wmapE)
  apply (erule spec [THEN mp, THEN spec, THEN mp])
   apply assumption
   apply (rule refl)
  done

subsection \<open>Projections\<close>

lemma wfstI: "<xa,ya> : r \<Longrightarrow> <<xa,xb>,<ya,yb>> : wmap(fst,r)"
  apply (rule wmapI)
  apply simp
  done

lemma wsndI: "<xb,yb> : r \<Longrightarrow> <<xa,xb>,<ya,yb>> : wmap(snd,r)"
  apply (rule wmapI)
  apply simp
  done

lemma wthdI: "<xc,yc> : r \<Longrightarrow> <<xa,<xb,xc>>,<ya,<yb,yc>>> : wmap(thd,r)"
  apply (rule wmapI)
  apply simp
  done

subsection \<open>Ground well-founded relations\<close>

lemma wfI: "\<lbrakk>Wfd(r);  a : r\<rbrakk> \<Longrightarrow> a : wf(r)"
  unfolding wf_def by blast

lemma Empty_wf: "Wfd({})"
  unfolding Wfd_def by (blast elim: EmptyXH [THEN iffD1, THEN FalseE])

lemma wf_wf: "Wfd(wf(R))"
  unfolding wf_def
  apply (rule_tac Q = "Wfd(R)" in excluded_middle [THEN disjE])
   apply simp_all
  apply (rule Empty_wf)
  done

lemma NatPRXH: "p : NatPR \<longleftrightarrow> (EX x:Nat. p=<x,succ(x)>)"
  unfolding NatPR_def by blast

lemma ListPRXH: "p : ListPR(A) \<longleftrightarrow> (EX h:A. EX t:List(A).p=<t,h$t>)"
  unfolding ListPR_def by blast

lemma NatPRI: "x : Nat \<Longrightarrow> <x,succ(x)> : NatPR"
  by (auto simp: NatPRXH)

lemma ListPRI: "\<lbrakk>t : List(A); h : A\<rbrakk> \<Longrightarrow> <t,h $ t> : ListPR(A)"
  by (auto simp: ListPRXH)

lemma NatPR_wf: "Wfd(NatPR)"
  apply (unfold Wfd_def)
  apply clarify
  apply (wfd_strengthen "\<lambda>x. x:Nat")
   apply (fastforce iff: NatPRXH)
  apply (erule Nat_ind)
   apply (fastforce iff: NatPRXH)+
  done

lemma ListPR_wf: "Wfd(ListPR(A))"
  apply (unfold Wfd_def)
  apply clarify
  apply (wfd_strengthen "\<lambda>x. x:List (A)")
   apply (fastforce iff: ListPRXH)
  apply (erule List_ind)
   apply (fastforce iff: ListPRXH)+
  done

subsection \<open>General Recursive Functions\<close>

lemma letrecT:
  assumes 1: "a : A"
    and 2: "\<And>p g. \<lbrakk>p:A; ALL x:{x: A. <x,p>:wf(R)}. g(x) : D(x)\<rbrakk> \<Longrightarrow> h(p,g) : D(p)"
  shows "letrec g x be h(x,g) in g(a) : D(a)"
  apply (rule 1 [THEN rev_mp])
  apply (rule wf_wf [THEN wfd_induct])
  apply (subst letrecB)
  apply (rule impI)
  apply (erule 2)
  apply blast
  done

lemma SPLITB: "SPLIT(<a,b>,B) = B(a,b)"
  unfolding SPLIT_def
  apply (rule set_ext)
  apply blast
  done

lemma letrec2T:
  assumes "a : A"
    and "b : B"
    and "\<And>p q g. \<lbrakk>p:A; q:B;
              ALL x:A. ALL y:{y: B. <<x,y>,<p,q>>:wf(R)}. g(x,y) : D(x,y)\<rbrakk> \<Longrightarrow>
                h(p,q,g) : D(p,q)"
  shows "letrec g x y be h(x,y,g) in g(a,b) : D(a,b)"
  apply (unfold letrec2_def)
  apply (rule SPLITB [THEN subst])
  apply (assumption | rule letrecT pairT splitT assms)+
  apply (subst SPLITB)
  apply (assumption | rule ballI SubtypeI assms)+
  apply (rule SPLITB [THEN subst])
  apply (assumption | rule letrecT SubtypeI pairT splitT assms |
    erule bspec SubtypeE sym [THEN subst])+
  done

lemma lem: "SPLIT(<a,<b,c>>,\<lambda>x xs. SPLIT(xs,\<lambda>y z. B(x,y,z))) = B(a,b,c)"
  by (simp add: SPLITB)

lemma letrec3T:
  assumes "a : A"
    and "b : B"
    and "c : C"
    and "\<And>p q r g. \<lbrakk>p:A; q:B; r:C;
       ALL x:A. ALL y:B. ALL z:{z:C. <<x,<y,z>>,<p,<q,r>>> : wf(R)}.
                                                        g(x,y,z) : D(x,y,z) \<rbrakk> \<Longrightarrow>
                h(p,q,r,g) : D(p,q,r)"
  shows "letrec g x y z be h(x,y,z,g) in g(a,b,c) : D(a,b,c)"
  apply (unfold letrec3_def)
  apply (rule lem [THEN subst])
  apply (assumption | rule letrecT pairT splitT assms)+
  apply (simp add: SPLITB)
  apply (assumption | rule ballI SubtypeI assms)+
  apply (rule lem [THEN subst])
  apply (assumption | rule letrecT SubtypeI pairT splitT assms |
    erule bspec SubtypeE sym [THEN subst])+
  done

lemmas letrecTs = letrecT letrec2T letrec3T

subsection \<open>Type Checking for Recursive Calls\<close>

lemma rcallT:
  "\<lbrakk>ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);
    g(a) : D(a) \<Longrightarrow> g(a) : E;  a:A;  <a,p>:wf(R)\<rbrakk> \<Longrightarrow> g(a) : E"
  by blast

lemma rcall2T:
  "\<lbrakk>ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y);
    g(a,b) : D(a,b) \<Longrightarrow> g(a,b) : E; a:A; b:B; <<a,b>,<p,q>>:wf(R)\<rbrakk> \<Longrightarrow> g(a,b) : E"
  by blast

lemma rcall3T:
  "\<lbrakk>ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}. g(x,y,z):D(x,y,z);
    g(a,b,c) : D(a,b,c) \<Longrightarrow> g(a,b,c) : E;
    a:A; b:B; c:C; <<a,<b,c>>,<p,<q,r>>> : wf(R)\<rbrakk> \<Longrightarrow> g(a,b,c) : E"
  by blast

lemmas rcallTs = rcallT rcall2T rcall3T

subsection \<open>Instantiating an induction hypothesis with an equality assumption\<close>

lemma hyprcallT:
  assumes 1: "g(a) = b"
    and 2: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x)"
    and 3: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> b=g(a) \<Longrightarrow> g(a) : D(a) \<Longrightarrow> P"
    and 4: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> a:A"
    and 5: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> <a,p>:wf(R)"
  shows P
  apply (rule 3 [OF 2, OF 1 [symmetric]])
  apply (rule rcallT [OF 2])
    apply assumption
   apply (rule 4 [OF 2])
  apply (rule 5 [OF 2])
  done

lemma hyprcall2T:
  assumes 1: "g(a,b) = c"
    and 2: "ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y)"
    and 3: "\<lbrakk>c = g(a,b); g(a,b) : D(a,b)\<rbrakk> \<Longrightarrow> P"
    and 4: "a:A"
    and 5: "b:B"
    and 6: "<<a,b>,<p,q>>:wf(R)"
  shows P
  apply (rule 3)
    apply (rule 1 [symmetric])
  apply (rule rcall2T)
      apply (rule 2)
     apply assumption
    apply (rule 4)
   apply (rule 5)
  apply (rule 6)
  done

lemma hyprcall3T:
  assumes 1: "g(a,b,c) = d"
    and 2: "ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z)"
    and 3: "\<lbrakk>d = g(a,b,c); g(a,b,c) : D(a,b,c)\<rbrakk> \<Longrightarrow> P"
    and 4: "a:A"
    and 5: "b:B"
    and 6: "c:C"
    and 7: "<<a,<b,c>>,<p,<q,r>>> : wf(R)"
  shows P
  apply (rule 3)
   apply (rule 1 [symmetric])
  apply (rule rcall3T)
       apply (rule 2)
      apply assumption
     apply (rule 4)
    apply (rule 5)
   apply (rule 6)
  apply (rule 7)
  done

lemmas hyprcallTs = hyprcallT hyprcall2T hyprcall3T

subsection \<open>Rules to Remove Induction Hypotheses after Type Checking\<close>

lemma rmIH1: "\<lbrakk>ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x); P\<rbrakk> \<Longrightarrow> P" .

lemma rmIH2: "\<lbrakk>ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); P\<rbrakk> \<Longrightarrow> P" .

lemma rmIH3:
 "\<lbrakk>ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z); P\<rbrakk> \<Longrightarrow> P" .

lemmas rmIHs = rmIH1 rmIH2 rmIH3

subsection \<open>Lemmas for constructors and subtypes\<close>

(* 0-ary constructors do not need additional rules as they are handled *)
(*                                      correctly by applying SubtypeI *)

lemma Subtype_canTs:
  "\<And>a b A B P. a : {x:A. b:{y:B(a).P(<x,y>)}} \<Longrightarrow> <a,b> : {x:Sigma(A,B).P(x)}"
  "\<And>a A B P. a : {x:A. P(inl(x))} \<Longrightarrow> inl(a) : {x:A+B. P(x)}"
  "\<And>b A B P. b : {x:B. P(inr(x))} \<Longrightarrow> inr(b) : {x:A+B. P(x)}"
  "\<And>a P. a : {x:Nat. P(succ(x))} \<Longrightarrow> succ(a) : {x:Nat. P(x)}"
  "\<And>h t A P. h : {x:A. t : {y:List(A).P(x$y)}} \<Longrightarrow> h$t : {x:List(A).P(x)}"
  by (assumption | rule SubtypeI canTs icanTs | erule SubtypeE)+

lemma letT: "\<lbrakk>f(t):B; \<not>t=bot\<rbrakk> \<Longrightarrow> let x be t in f(x) : B"
  apply (erule letB [THEN ssubst])
  apply assumption
  done

lemma applyT2: "\<lbrakk>a:A; f : Pi(A,B)\<rbrakk> \<Longrightarrow> f ` a  : B(a)"
  apply (erule applyT)
  apply assumption
  done

lemma rcall_lemma1: "\<lbrakk>a:A; a:A \<Longrightarrow> P(a)\<rbrakk> \<Longrightarrow> a : {x:A. P(x)}"
  by blast

lemma rcall_lemma2: "\<lbrakk>a:{x:A. Q(x)}; \<lbrakk>a:A; Q(a)\<rbrakk> \<Longrightarrow> P(a)\<rbrakk> \<Longrightarrow> a : {x:A. P(x)}"
  by blast

lemmas rcall_lemmas = asm_rl rcall_lemma1 SubtypeD1 rcall_lemma2

subsection \<open>Typechecking\<close>

ML \<open>
local

val type_rls =
  @{thms canTs} @ @{thms icanTs} @ @{thms applyT2} @ @{thms ncanTs} @ @{thms incanTs} @
  @{thms precTs} @ @{thms letrecTs} @ @{thms letT} @ @{thms Subtype_canTs};

fun bvars \<^Const_>\<open>Pure.all _ for \<open>Abs(s,_,t)\<close>\<close> l = bvars t (s::l)
  | bvars _ l = l

fun get_bno l n \<^Const_>\<open>Pure.all _ for \<open>Abs(s,_,t)\<close>\<close> = get_bno (s::l) n t
  | get_bno l n \<^Const_>\<open>Trueprop for t\<close> = get_bno l n t
  | get_bno l n \<^Const_>\<open>Ball _ for _ \<open>Abs(s,_,t)\<close>\<close> = get_bno (s::l) (n+1) t
  | get_bno l n \<^Const_>\<open>mem _ for t _\<close> = get_bno l n t
  | get_bno l n (t $ s) = get_bno l n t
  | get_bno l n (Bound m) = (m-length(l),n)

(* Not a great way of identifying induction hypothesis! *)
fun could_IH x = Term.could_unify(x,hd (Thm.prems_of @{thm rcallT})) orelse
                 Term.could_unify(x,hd (Thm.prems_of @{thm rcall2T})) orelse
                 Term.could_unify(x,hd (Thm.prems_of @{thm rcall3T}))

fun IHinst tac rls = SUBGOAL (fn (Bi,i) =>
  let val bvs = bvars Bi []
      val ihs = filter could_IH (Logic.strip_assums_hyp Bi)
      val rnames = map (fn x =>
                    let val (a,b) = get_bno [] 0 x
                    in (nth bvs a, b) end) ihs
      fun try_IHs [] = no_tac
        | try_IHs ((x,y)::xs) =
            tac [((("g", 0), Position.none), x)] (nth rls (y - 1)) i ORELSE (try_IHs xs)
  in try_IHs rnames end)

fun is_rigid_prog t =
  (case (Logic.strip_assums_concl t) of
    \<^Const_>\<open>Trueprop for \<^Const_>\<open>mem _ for a _\<close>\<close> => null (Term.add_vars a [])
  | _ => false)

in

fun rcall_tac ctxt i =
  let fun tac ps rl i = Rule_Insts.res_inst_tac ctxt ps [] rl i THEN assume_tac ctxt i
  in IHinst tac @{thms rcallTs} i end
  THEN eresolve_tac ctxt @{thms rcall_lemmas} i

fun raw_step_tac ctxt prems i =
  assume_tac ctxt i ORELSE
  resolve_tac ctxt (prems @ type_rls) i ORELSE
  rcall_tac ctxt i ORELSE
  ematch_tac ctxt @{thms SubtypeE} i ORELSE
  match_tac ctxt @{thms SubtypeI} i

fun tc_step_tac ctxt prems = SUBGOAL (fn (Bi,i) =>
    if is_rigid_prog Bi then raw_step_tac ctxt prems i else no_tac)

fun typechk_tac ctxt rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac ctxt rls)) i

(*** Clean up Correctness Condictions ***)

fun clean_ccs_tac ctxt =
  let fun tac ps rl i = Rule_Insts.eres_inst_tac ctxt ps [] rl i THEN assume_tac ctxt i in
    TRY (REPEAT_FIRST (IHinst tac @{thms hyprcallTs} ORELSE'
      eresolve_tac ctxt ([asm_rl, @{thm SubtypeE}] @ @{thms rmIHs}) ORELSE'
      hyp_subst_tac ctxt))
  end

fun gen_ccs_tac ctxt rls i =
  SELECT_GOAL (REPEAT_FIRST (tc_step_tac ctxt rls) THEN clean_ccs_tac ctxt) i

end
\<close>

method_setup typechk = \<open>
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (typechk_tac ctxt ths))
\<close>

method_setup clean_ccs = \<open>
  Scan.succeed (SIMPLE_METHOD o clean_ccs_tac)
\<close>

method_setup gen_ccs = \<open>
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (gen_ccs_tac ctxt ths))
\<close>

subsection \<open>Evaluation\<close>

named_theorems eval "evaluation rules"

ML \<open>
fun eval_tac ths =
  Subgoal.FOCUS_PREMS (fn {context = ctxt, prems, ...} =>
    let val eval_rules = Named_Theorems.get ctxt \<^named_theorems>\<open>eval\<close>
    in DEPTH_SOLVE_1 (resolve_tac ctxt (ths @ prems @ rev eval_rules) 1) end)
\<close>

method_setup eval = \<open>
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (CHANGED o eval_tac ths ctxt))
\<close>

lemmas eval_rls [eval] = trueV falseV pairV lamV caseVtrue caseVfalse caseVpair caseVlam

lemma applyV [eval]:
  assumes "f \<longlongrightarrow> lam x. b(x)"
    and "b(a) \<longlongrightarrow> c"
  shows "f ` a \<longlongrightarrow> c"
  unfolding apply_def by (eval assms)

lemma letV:
  assumes 1: "t \<longlongrightarrow> a"
    and 2: "f(a) \<longlongrightarrow> c"
  shows "let x be t in f(x) \<longlongrightarrow> c"
  apply (unfold let_def)
  apply (rule 1 [THEN canonical])
  apply (tactic \<open>
    REPEAT (DEPTH_SOLVE_1 (resolve_tac \<^context> (@{thms assms} @ @{thms eval_rls}) 1 ORELSE
      eresolve_tac \<^context> @{thms substitute} 1))\<close>)
  done

lemma fixV: "f(fix(f)) \<longlongrightarrow> c \<Longrightarrow> fix(f) \<longlongrightarrow> c"
  apply (unfold fix_def)
  apply (rule applyV)
   apply (rule lamV)
  apply assumption
  done

lemma letrecV:
  "h(t,\<lambda>y. letrec g x be h(x,g) in g(y)) \<longlongrightarrow> c \<Longrightarrow>
                 letrec g x be h(x,g) in g(t) \<longlongrightarrow> c"
  apply (unfold letrec_def)
  apply (assumption | rule fixV applyV  lamV)+
  done

lemmas [eval] = letV letrecV fixV

lemma V_rls [eval]:
  "true \<longlongrightarrow> true"
  "false \<longlongrightarrow> false"
  "\<And>b c t u. \<lbrakk>b\<longlongrightarrow>true; t\<longlongrightarrow>c\<rbrakk> \<Longrightarrow> if b then t else u \<longlongrightarrow> c"
  "\<And>b c t u. \<lbrakk>b\<longlongrightarrow>false; u\<longlongrightarrow>c\<rbrakk> \<Longrightarrow> if b then t else u \<longlongrightarrow> c"
  "\<And>a b. <a,b> \<longlongrightarrow> <a,b>"
  "\<And>a b c t h. \<lbrakk>t \<longlongrightarrow> <a,b>; h(a,b) \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> split(t,h) \<longlongrightarrow> c"
  "zero \<longlongrightarrow> zero"
  "\<And>n. succ(n) \<longlongrightarrow> succ(n)"
  "\<And>c n t u. \<lbrakk>n \<longlongrightarrow> zero; t \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> ncase(n,t,u) \<longlongrightarrow> c"
  "\<And>c n t u x. \<lbrakk>n \<longlongrightarrow> succ(x); u(x) \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> ncase(n,t,u) \<longlongrightarrow> c"
  "\<And>c n t u. \<lbrakk>n \<longlongrightarrow> zero; t \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> nrec(n,t,u) \<longlongrightarrow> c"
  "\<And>c n t u x. \<lbrakk>n\<longlongrightarrow>succ(x); u(x,nrec(x,t,u))\<longlongrightarrow>c\<rbrakk> \<Longrightarrow> nrec(n,t,u)\<longlongrightarrow>c"
  "[] \<longlongrightarrow> []"
  "\<And>h t. h$t \<longlongrightarrow> h$t"
  "\<And>c l t u. \<lbrakk>l \<longlongrightarrow> []; t \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> lcase(l,t,u) \<longlongrightarrow> c"
  "\<And>c l t u x xs. \<lbrakk>l \<longlongrightarrow> x$xs; u(x,xs) \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> lcase(l,t,u) \<longlongrightarrow> c"
  "\<And>c l t u. \<lbrakk>l \<longlongrightarrow> []; t \<longlongrightarrow> c\<rbrakk> \<Longrightarrow> lrec(l,t,u) \<longlongrightarrow> c"
  "\<And>c l t u x xs. \<lbrakk>l\<longlongrightarrow>x$xs; u(x,xs,lrec(xs,t,u))\<longlongrightarrow>c\<rbrakk> \<Longrightarrow> lrec(l,t,u)\<longlongrightarrow>c"
  unfolding data_defs by eval+

subsection \<open>Factorial\<close>

schematic_goal
  "letrec f n be ncase(n,succ(zero),\<lambda>x. nrec(n,zero,\<lambda>y g. nrec(f(x),g,\<lambda>z h. succ(h))))
   in f(succ(succ(zero))) \<longlongrightarrow> ?a"
  by eval

schematic_goal
  "letrec f n be ncase(n,succ(zero),\<lambda>x. nrec(n,zero,\<lambda>y g. nrec(f(x),g,\<lambda>z h. succ(h))))
   in f(succ(succ(succ(zero)))) \<longlongrightarrow> ?a"
  by eval

subsection \<open>Less Than Or Equal\<close>

schematic_goal
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(zero), succ(zero)>) \<longlongrightarrow> ?a"
  by eval

schematic_goal
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(zero), succ(succ(succ(succ(zero))))>) \<longlongrightarrow> ?a"
  by eval

schematic_goal
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(succ(succ(succ(succ(zero))))), succ(succ(succ(succ(zero))))>) \<longlongrightarrow> ?a"
  by eval

subsection \<open>Reverse\<close>

schematic_goal
  "letrec id l be lcase(l,[],\<lambda>x xs. x$id(xs))
   in id(zero$succ(zero)$[]) \<longlongrightarrow> ?a"
  by eval

schematic_goal
  "letrec rev l be lcase(l,[],\<lambda>x xs. lrec(rev(xs),x$[],\<lambda>y ys g. y$g))
   in rev(zero$succ(zero)$(succ((lam x. x)`succ(zero)))$([])) \<longlongrightarrow> ?a"
  by eval

end