(*<*)
theory CounterExample
imports
  HOLCF
  WorkerWrapper
begin
(*>*)

subsection{* Worker/wrapper fusion is partially correct *}

text{*

We now examine how Gill and Hutton apply their worker/wrapper fusion
rule in the context of the fold/unfold framework.

The key step of those left implicit in the original paper is the use
of the \textsf{fold} rule to justify replacing the worker with the
fused version. Schematically, the fold/unfold framework maintains a
history of all definitions that have appeared during transformation,
and the \textsf{fold} rule treats this as a set of rewrite rules
oriented right-to-left. (The \textsf{unfold} rule treats the current
working set of definitions as rewrite rules oriented left-to-right.)
Hence as each definition @{haskell "f = body"} yields a rule of the form
@{haskell "body\\ \\Longrightarrow\\ f"}, one can always derive @{haskell "f =\\
f"}. Clearly this has dire implications for the preservation of
termination behaviour.

\citet{Tullsen:PhDThesis} in his \S3.1.2 observes that the semantic
essence of the \textsf{fold} rule is Park induction:
\begin{center}
  @{thm[mode=Rule] "fix_least"[where F=f]} {\texttt{fix\_least}}
\end{center}
viz that @{haskell "f\\ x = x"} implies only the partially correct @{haskell "fix\\ f
\\sqsubseteq x"}, and not the totally correct @{haskell "fix\\ f = x"}. We use
this characterisation to show that if @{haskell "unwrap"} is non-strict
(i.e. @{haskell "unwrap \\bot \\neq \\bot"}) then there are programs where
worker/wrapper fusion as used by Gill and Hutton need only be
partially correct.

Consider the scenario described in Figure~\ref{fig:ww}. After applying
the worker/wrapper transformation, we attempt to apply fusion by
finding a residual expression @{term "body'"} such that the body of
the worker, i.e. the expression @{term "unwrap oo body oo wrap"}, can
be rewritten as @{term "body' oo unwrap oo wrap"}. Intuitively this is
the semantic form of workers where all self-calls are fusible. Our
goal is to justify redefining @{term "work"} to @{term "fix\<cdot>body'"},
i.e. to establish:
\begin{center}
  @{term "fix\<cdot>(unwrap oo body oo wrap) = fix\<cdot>body'"}
\end{center}
We show that worker/wrapper fusion as proposed by Gill and Hutton is
partially correct using Park induction:

*}

lemma fusion_partially_correct:
  assumes wrap_unwrap: "wrap oo unwrap = ID"
  assumes work: "work = fix\<cdot>(unwrap oo body oo wrap)"
  assumes body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  shows "fix\<cdot>body' \<sqsubseteq> work"
proof(rule fix_least)
  have "work = (unwrap oo body oo wrap)\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap)\<cdot>work"
    using body' by simp
  also have "... = (body' oo unwrap oo wrap)\<cdot>((unwrap oo body oo wrap)\<cdot>work)"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap oo unwrap oo body oo wrap)\<cdot>work"
    by simp
  also have "... = (body' oo unwrap oo body oo wrap)\<cdot>work"
    using wrap_unwrap by (simp add: assoc_oo)
  also have "... = body'\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  finally show "body'\<cdot>work = work" by simp
qed

text{*

The next section shows the converse does not obtain.

*}

subsection{* A non-strict @{term "unwrap"} may go awry *}

text{*

\label{sec:ww-counterexample}

If @{term "unwrap"} is non-strict, then it is possible that the fusion
rule proposed by Gill and Hutton does not preserve termination. To
show this we take a small artificial example. The type @{term "A"} is
not important, but we need access to a non-bottom inhabitant. The
target type @{term "B"} is the non-strict lift of @{term "A"}.

*}

domain A = A
domain B = B (lazy "A")

text{*

The functions @{term "wrap"} and @{term "unwrap"} that map between
these types are routine. Note that @{term "wrap"} is (necessarily)
strict due to the property @{thm "retraction_strict"}.

*}

fixrec wrap :: "B \<rightarrow> A"
where "wrap\<cdot>(B\<cdot>a) = a"

(*<*)
lemma wrap_strict[simp]: "wrap\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp
(*>*)

fixrec unwrap :: "A \<rightarrow> B"
where "unwrap = B"

text{*

Discharging the worker/wrapper hypothesis is similarly routine.

*}

lemma wrap_unwrap: "wrap oo unwrap = ID"
  by (simp add: cfun_eq_iff)

text{*

The candidate computation we transform can be any that uses the
recursion parameter @{term "r"} non-strictly. The following is
especially trivial.

*}

fixrec body :: "A \<rightarrow> A"
where "body\<cdot>r = A"

text{*

The wrinkle is that the transformed worker can be strict in the
recursion parameter @{term "r"}, as @{term "unwrap"} always lifts it.

*}

fixrec body' :: "B \<rightarrow> B"
where "body'\<cdot>(B\<cdot>a) = B\<cdot>A"
(*<*)

lemma body'_strict[simp]: "body'\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

(*>*)
text{*

As explained above, we set up the fusion opportunity:

*}

lemma body_body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  by (simp add: cfun_eq_iff)

text{*

This result depends crucially on @{term "unwrap"} being non-strict.

Our earlier result shows that the proposed transformation is partially
correct:

*}

lemma "fix\<cdot>body' \<sqsubseteq> fix\<cdot>(unwrap oo body oo wrap)"
  by (rule fusion_partially_correct[OF wrap_unwrap refl body_body'])

text{*

However it is easy to see that it is not totally correct:

*}

lemma "\<not> fix\<cdot>(unwrap oo body oo wrap) \<sqsubseteq> fix\<cdot>body'"
proof -
  have l: "fix\<cdot>(unwrap oo body oo wrap) = B\<cdot>A"
    by (subst fix_eq) simp
  have r: "fix\<cdot>body' = \<bottom>"
    by (simp add: fix_strict)
  from l r show ?thesis by simp
qed

text{*

This trick works whenever @{term "unwrap"} is not strict. In the
following section we show that requiring @{term "unwrap"} to be strict
leads to a straightforward proof of total correctness.

Note that if we have already established that @{term "wrap oo unwrap =
ID"}, then making @{term "unwrap"} strict preserves this equation:

*}

lemma
  assumes "wrap oo unwrap = ID"
  shows "wrap oo strictify\<cdot>unwrap = ID"
proof(rule cfun_eqI)
  fix x
  from assms
  show "(wrap oo strictify\<cdot>unwrap)\<cdot>x = ID\<cdot>x"
    by (cases "x = \<bottom>") (simp_all add: cfun_eq_iff retraction_strict)
qed

text{*

From this we conclude that the worker/wrapper transformation itself
cannot exploit any laziness in @{term "unwrap"} under the
context-insensitive assumptions of @{thm [source]
"worker_wrapper_id"}. This is not to say that other program
transformations may not be able to.

*}

(*<*)
lemma
  "\<not> strictify\<cdot>unwrap oo body oo wrap = body' oo strictify\<cdot>unwrap oo wrap"
  by (simp add: cfun_eq_iff exI[where x="\<bottom>"])
(*>*)

(*<*)
end
(*>*)


section \<open>Approximation of the Bell numbers\<close>

text \<open>Important note: I intend to move the formalization in this file to the existing AFP entry
Bell_Numbers_Spivey, assuming Lukas Bulwahn has no objections --- if/after this submission is
accepted.\<close>

theory Bell_Asymptotics
  imports
    Bell_Numbers_Spivey.Bell_Numbers
    "HOL-Decision_Procs.Approximation"
    "Stirling_Formula.Stirling_Formula"
    "Lambert_W.Lambert_W"
    "../DDE_Transcendental_Extras"
begin

subsection \<open>Some preliminary generic results\<close>

subsection \<open>Fast evaluation of Bell numbers\<close>

text \<open>The proof by Berend and Tassa below requires explicit values of the Bell numbers upto 54.
It however is difficult/extremely slow to compute Bell numbers in that range without dynamic
programming (DP). The following is a DP algorithm derived from the recursion formula
@{thm [source] Bell_recursive_eq}.\<close>

fun bell_list_aux :: "nat \<Rightarrow> nat list"
  where
  "bell_list_aux 0 = [1]" |
  "bell_list_aux (Suc n) = (
    let x = bell_list_aux n;
        y = sum_list (map (\<lambda>(k, z). z * (n choose (n-k))) (List.enumerate 0 x))
    in y#x)"

definition bell_list :: "nat \<Rightarrow> nat list"
  where "bell_list n = rev (bell_list_aux n)"

lemma bell_list_eq: "bell_list n = map Bell [0..<n+1]"
proof -
  have "bell_list_aux n = rev (map Bell [0..<Suc n])"
  proof (induction n)
    case 0
    then show ?case by (simp add:Bell_0)
  next
    case (Suc n)
    define x where "x = bell_list_aux n"
    define y where "y = sum_list (map (\<lambda>(k,z). z * (n choose (n-k))) (List.enumerate 0 x))"
    define sn where "sn = n+1"
    have b:"x = rev (map Bell [0..<sn])"
      using Suc x_def sn_def by simp
    have c: "length x = sn"
      unfolding b by simp

    have "snd i = Bell (n - fst i)" if "i \<in> set (List.enumerate 0 x)" for i
    proof -
      have "fst i < length x" "snd i = x ! fst i"
        using iffD1[OF in_set_enumerate_eq that] by auto
      hence "snd i = Bell (sn - Suc (fst i))"
        unfolding b by (simp add:rev_nth)
      thus ?thesis
        unfolding sn_def by simp
    qed

    hence "y = sum_list (map (\<lambda>i. Bell (n-fst i) * (n choose (n-fst i))) (List.enumerate 0 x))"
      unfolding y_def by (intro arg_cong[where f="sum_list"] map_cong refl)
        (simp add:case_prod_beta)
    also have "... = sum_list (map (\<lambda>i. Bell (n-i) * (n choose (n-i))) (map fst (List.enumerate 0 x)))"
      by (subst map_map) (simp add:comp_def)
    also have "... = (\<Sum>i= 0..<length x. Bell (n-i) * (n choose (n-i)))"
      by (simp add:interv_sum_list_conv_sum_set_nat)
    also have "... = (\<Sum>i\<le>n. Bell (n-i) * (n choose (n-i)))"
      using c sn_def by (intro sum.cong) auto
    also have "... = (\<Sum>i \<in> (\<lambda>k. n- k) ` {..n}. Bell i * (n choose i))"
      by (subst sum.reindex, auto simp add:inj_on_def)
    also have "... = (\<Sum>i \<le> n. Bell i * (n choose i))"
      by (intro sum.cong refl iffD2[OF set_eq_iff] allI)
        (simp add:image_iff atMost_def, presburger)
    also have "... = Bell (Suc n)"
      using Bell_recursive_eq by (simp add:mult.commute)
    finally have a: "y = Bell (Suc n)" by simp

    have "bell_list_aux (Suc n) = y#x"
      unfolding x_def y_def by (simp add:Let_def)
    also have "... = Bell (Suc n)#(rev (map Bell [0..<Suc n]))"
      unfolding a b sn_def by simp
    also have "... = rev (map Bell [0..<Suc (Suc n)])"
      by simp
    finally show ?case by simp
  qed
  thus "bell_list n = map Bell [0..<n+1]"
    by (simp add:bell_list_def)
qed

subsection \<open>Dobi\'{n}ski's Formula\<close>

lemma dobinskis_formula_raw: "(\<lambda>k. real k^n / fact k) sums (exp 1 * Bell n)"
proof (induction n rule:nat_less_induct)
  case (1 n)
  show ?case
  proof (cases n)
    case 0
    have "(\<lambda>k. (1::real) ^ k /\<^sub>R fact k) sums (exp 1)"
      by (intro exp_converges)
    thus "(\<lambda>k. real k ^ n / fact k) sums (exp 1 * Bell n)"
      using 0 Bell_0 by (simp add:divide_inverse)
  next
    case (Suc m)
    have a: "real (k + 1) = real k+1" for k by simp

    have "(\<lambda>k. (\<Sum>j \<le> m. real (m choose j) *\<^sub>R (real k ^ j / fact k))) sums
      (\<Sum>j \<le> m. real (m choose j) *\<^sub>R (exp 1 * Bell j))" (is "?L sums ?R")
      using Suc by (intro sums_sum sums_scaleR_right mp[OF spec[OF 1]]) simp
    hence "(\<lambda>k. (\<Sum>j \<le> m. real (m choose j) * (real k) ^ j * 1 ^ (m-j)) / fact k) sums
     (\<Sum>j \<le> m. exp 1 * real (m choose j) * Bell j)"
      by (subst sum_divide_distrib) (simp add:algebra_simps)
    hence "(\<lambda>k. (real k+1) ^ m / fact k) sums (exp 1 * real (Bell (m+1)))"
      unfolding binomial_ring Bell_recursive_eq by (simp add:sum_distrib_left algebra_simps)
    hence "(\<lambda>k. real (k+1) ^ m / fact k) sums (exp 1 * real (Bell (m+1)))"
      by (subst a) simp
    hence "(\<lambda>k. real (k+1) ^ (m+1) / fact (Suc k)) sums (exp 1 * real (Bell (m + 1)))"
      unfolding fact_Suc by simp
    hence "(\<lambda>k. real k ^ (m+1) / fact k) sums (exp 1 * Bell (m+1) + real 0^(m+1) / fact 0)"
      by (intro sums_Suc) simp
    hence "(\<lambda>k. real k ^ (m+1) / fact k) sums (exp 1 * Bell (m+1))"
      by simp
    thus "(\<lambda>k. real k ^ n / fact k) sums (exp 1 * Bell n)"
      using Suc by simp
  qed
qed

theorem dobinskis_formula:
  shows "summable (\<lambda>k. real k^n / fact k)"
  and "Bell n = 1 / exp 1 * (\<Sum>k. real k^n / fact k)"
  using sums_summable dobinskis_formula_raw[of n] sums_unique
  by (auto simp add:algebra_simps eq_divide_eq)

subsection \<open>Approximation by Berend and Tassa\<close>

text \<open>In this subsection we verify \cite[Theorem 2.2]{berend2010} for the Bell numbers, which is the
approximation formula:
\[
  B_n < \left( \frac{e^{-0.6+\varepsilon} n}{\ln(n+1)} \right)^n
\]
iff $n \geq 55$ and $\eps > d(n)$ which is defined by
$d(n) := \ln \ln (n+1) - \ln \ln n + \frac{1+e^{-1}}{\ln n}$.

The following is the corresponding Isabelle definition for $d$ above.\<close>

definition bell_approx_d :: "real \<Rightarrow> real"
  where "bell_approx_d x = ln (ln (x+1)) - ln (ln x)  + (1 + exp(-1))/ln x"

lemma bell_approx_d_nonneg:
  assumes "1 < x"
  shows "bell_approx_d x \<ge> 0"
proof-
  have "(0::real) \<le> 0 + 0" by simp
  also have "... \<le> (ln (ln(x+1)) - ln (ln x)) + (1 + exp(-1))/ln x"
    using assms by (intro add_mono) auto
  also have "... = bell_approx_d x"
    unfolding bell_approx_d_def by simp
  finally show ?thesis by simp
qed

lemma bell_approx_d_decreasing:
  assumes "1 < x" "x \<le> y"
  shows "bell_approx_d y \<le> bell_approx_d x"
proof -
  have y_ge_1: "y > 1" using assms by auto

  have "ln (y+1)/ln y = 1+(ln (y+1)-ln y)/ln y"
    using y_ge_1 by (simp add:algebra_simps diff_divide_distrib)
  also have "... = 1 + ln(1+1/y)* (1/ln y)"
    using y_ge_1 by (subst ln_div[symmetric])
    (auto simp add:algebra_simps add_divide_distrib)
  also have "... \<le> 1 + ln(1+1/x) *(1/ln x)"
    using y_ge_1 assms
    by (intro add_mono mult_mono iffD2[OF ln_le_cancel_iff] add_pos_pos divide_left_mono) auto
  also have "... = 1+(ln (x+1)-ln x)/ln x"
    using assms by (subst ln_div[symmetric])
     (auto simp add:algebra_simps add_divide_distrib)
  also have "... = ln (x+1)/ln x"
    using assms by (simp add:algebra_simps diff_divide_distrib)
  finally have a:"ln (y+1)/ln y \<le> ln (x+1)/ln x"
    by simp
  have "ln (ln (y+1)) - ln (ln y) = ln (ln(y+1)/ln y)"
    using y_ge_1 by (subst ln_div) auto
  also have "... \<le> ln (ln(x+1)/ln x)"
    using assms y_ge_1
    by (intro iffD2[OF ln_le_cancel_iff] a divide_pos_pos) auto
  also have "... = ln (ln (x+1)) - ln (ln x)"
    using assms by (subst ln_div) auto
  finally have b:"ln (ln (y+1)) - ln (ln y) \<le> ln (ln (x+1)) - ln (ln x)"
    by simp
  show ?thesis
    unfolding bell_approx_d_def using y_ge_1 assms
    by (intro add_mono b divide_left_mono iffD2[OF ln_le_cancel_iff])
     auto
qed

text \<open>The theorem bellow corresponds to Theorem 2.2 from Berend and Tassa for the Bell numbers.
Whenever possible I attached facts derived here with the corresponding Equation from their proof.

They introduce a generalization of the bell numbers called the Bell function defined
on the positive real numbers. Because I could not find any other sources that make use of that
generalization, I avoided introducing it, so the result below is a restriction of their theorem
to the "classical" Bell numbers.

Another distinction is that they define the extremal point $x_0$ of the function $h$ implicitly,
while here a closed form expression is derived using the Lambert W function.\<close>

theorem bell_approx_1:
  assumes "bell_approx_d n \<le> \<epsilon>"
  assumes "n \<ge> 55"
  shows "real (Bell n) < (exp (-0.6+\<epsilon>) * n / ln (n + 1)) powr n" (is "?L < ?R")
proof -
  have apx:
    "exp (-0.0007) powr 55 < (0.97::real)"
    "exp (-55) \<le> (0.03::real)"
    "2 * exp (-1) \<le> (1::real)"
    "exp 1 \<le> (55::real)"
    "exp 4 \<le> (110::real)"
    "ln (1 + 1 / exp 1) - 1 + (ln 55 + ln 2) / 55 \<le> (- 0.6007::real)"
    by (approximation 13)+

  text \<open>Since n > 0 we can omit the first term from Dobi\'{n}ski's formula.\<close>
  have zero_pow_n: "0^n = (0::real)"
    using assms by simp
  have dobinski_suc: "(\<lambda>k. real (Suc k)^n / fact (Suc k)) sums (exp 1 * Bell n)"
    using dobinskis_formula_raw[of n]
    by (intro iffD2[OF sums_Suc_iff]) (simp add:zero_pow_n)

  let ?p = "real n"

  have "0 \<le> bell_approx_d n"
    using assms(2) by (intro bell_approx_d_nonneg) simp
  also have "... \<le> \<epsilon>" using assms(1) by simp
  finally have \<epsilon>_ge_0: "\<epsilon> \<ge> 0" by simp

  text \<open>The definitions @{term "\<alpha>"}, @{term "h"}, @{term "v"}, @{term "x0"} bellow correspond
  to the variables of the same name from Lemma~3.1 and Theorem~2.2 from Berend and Tassa.\<close>

  define \<alpha> :: real where "\<alpha> = 1+1/exp 1"
  define h where "h = (\<lambda>x. x + ?p * ln x - x * ln x)"
  define h' where "h' = (\<lambda>x. ?p / x - ln x)"
  define h_max where "h_max = ?p * (ln ?p - ln (ln (?p+1))+\<epsilon>+ln \<alpha>-1)"
  define h_ub where "h_ub = (\<lambda>x. if x < 2*n then h_max else - (Suc x))"

  text \<open>This is the extremum of the function h.\<close>
  define x0 :: real where "x0 = exp (Lambert_W ?p)"

  define v :: "real \<Rightarrow> real" where "v = (\<lambda>x. \<alpha> * ln \<alpha> + (\<alpha>-1)*ln x - \<alpha>*ln (ln x))"
  define v' :: "real \<Rightarrow> real" where "v' = (\<lambda>x. (\<alpha>-1)/x - \<alpha>/(x*ln x))"

  text \<open>This is the zero point of the function @{term "v"}.\<close>
  define v0 :: real where "v0 = exp (exp 1+1)"

  have \<alpha>_gt_1: "\<alpha> > 1"
    unfolding \<alpha>_def by (approximation 5)
  have v0_gt_1: "v0 > 1"
    unfolding v0_def by (approximation 4)
  have v0_le_55: "v0 \<le> 55"
    unfolding v0_def by (approximation 7)

  have "(v has_real_derivative (v' x)) (at x)" if "x > 1" for x
    unfolding v_def v'_def using that
    by (auto intro!: derivative_eq_intros)
  hence v_deriv: "(v has_real_derivative (v' x)) (at x)" if "x \<ge> v0" for x
    using that v0_gt_1 by simp

  have v_deriv_nonneg: "v' x \<ge> 0" if "x \<ge> v0" for x
  proof -
    have "0 \<le> (\<alpha>-1)*ln v0 - \<alpha>"
      unfolding \<alpha>_def v0_def by (simp add:algebra_simps add_divide_distrib)
    also have "... \<le> (\<alpha>-1)*ln x - \<alpha>"
      using that v0_gt_1 \<alpha>_gt_1
      by (intro diff_mono mult_left_mono ln_le_cancel_iff[THEN iffD2]) auto
    finally have "0 \<le> (\<alpha>-1)*ln x - \<alpha>" by simp
    hence "0 \<le> ((\<alpha>-1)*ln x - \<alpha>) / (x*ln x)"
      using that v0_gt_1
      by (intro divide_nonneg_nonneg mult_nonneg_nonneg) auto
    also have "... = (\<alpha>-1)*ln x/(x*ln x) - \<alpha>/(x*ln x)"
      by (simp add:diff_divide_distrib)
    also have "... = v' x"
      using that v0_gt_1 unfolding v'_def by simp
    finally show ?thesis by simp
  qed

  have v_mono: "v x \<le> v y" if "x \<le> y" "x \<ge> v0" for x y
    using v_deriv v_deriv_nonneg that order_trans
    by (intro DERIV_nonneg_imp_nondecreasing[OF that(1)]) blast

  have "v v0 = v (exp(\<alpha>/(\<alpha>-1)))"
    unfolding v0_def \<alpha>_def
    by (simp add:algebra_simps)
  also have "... = \<alpha> * ln \<alpha> + \<alpha> -  \<alpha> * ln (\<alpha> / (\<alpha> - 1))"
    using \<alpha>_gt_1 unfolding v_def by simp
  also have "... = \<alpha> * (ln \<alpha> + 1 - ln \<alpha> + ln (\<alpha>-1))"
    using \<alpha>_gt_1 by (simp add:algebra_simps ln_div)
  also have "... = 0"
    unfolding \<alpha>_def by (simp add:ln_div)
  finally have v_zero: "v v0 = 0" by simp

  text \<open>The following block corresponds to Eq. 24.\<close>
  have x0_ge_1: "x0 \<ge> 1" unfolding x0_def by simp
  have "- exp (-1) \<le> (0::real)" using exp_ge_zero by simp
  also have "... \<le> real n" by simp
  finally have "- exp (- 1) \<le> real n" by simp
  hence eqn_24: "x0 * ln x0 = ?p"
    unfolding  x0_def by (auto intro!: Lambert_W_times_exp_self')

  text \<open>The following block corresponds to Eq. 25.\<close>
  have eqn_25: "x0 \<le> \<alpha> * ?p / ln ?p"
  proof (rule ccontr)
    assume "\<not> x0 \<le> \<alpha> * ?p / ln ?p"
    hence eqn_25_1: "\<alpha> * ?p / ln ?p < x0" by simp
    have "1 * ln (real n) \<le> \<alpha> * real n"
      using \<alpha>_gt_1  assms(2)
      by (intro mult_mono less_imp_le[OF ln_less_self]) auto
    hence "(\<alpha> * ?p / ln ?p) * ln (\<alpha> * ?p / ln ?p) < x0 * ln x0"
      using x0_ge_1 \<alpha>_gt_1 assms(2)
      by (intro mult_strict_mono iffD2[OF ln_less_cancel_iff] eqn_25_1) auto
    also have "... = ?p"
      using eqn_24 by simp
    finally have "?p * (\<alpha> / ln ?p * ln (\<alpha> * ?p / ln ?p)) < ?p * 1"
      by (simp add:algebra_simps)
    hence "\<alpha> / ln ?p * ln (\<alpha> * ?p / ln ?p) < 1"
      using assms(2) by (subst (asm) mult_less_cancel_left, simp)
    hence "\<alpha> * (ln \<alpha> + ln ?p - ln (ln ?p)) < ln ?p"
      using assms(2) \<alpha>_gt_1 by (simp add: ln_mult ln_div)
    hence "v ?p < 0" (* rev of Eq. 26 *)
      by (simp add: v_def algebra_simps)
    also have "... = v v0"
      using v_zero by simp
    also have "... \<le> v ?p"
      using assms(2) v0_le_55 by (intro v_mono) auto
    finally have "v ?p < v ?p" by simp
    thus "False" by simp
  qed

  define sum_h_ub where "sum_h_ub = (2* ?p) * exp h_max + exp(-(2*?p+1))/(1-exp(-1))"

  have "(\<lambda>x. exp (- (1::real)) ^ x) sums (1 / (1 - exp (- 1)))"
    by (intro geometric_sums) auto
  hence "(\<lambda>x. exp (- 1) powr real x) sums (1 / (1 - exp (- 1)))"
    by (subst powr_realpow) simp
  hence "(\<lambda>k. (exp(-1) *\<^sub>R exp(-1) powr k) *\<^sub>R exp (-2*?p))
    sums ( (exp(-1) *\<^sub>R (1/(1-exp(-1)))) *\<^sub>R exp(-2*?p))"
    by (intro sums_scaleR_left sums_scaleR_right)
  hence "(\<lambda>k. exp (h_ub (k + 2*n))) sums (exp(-(2*?p+1))/(1-exp(-1)))"
    unfolding h_ub_def by (simp add:exp_powr exp_add[symmetric] algebra_simps)
  hence "(\<lambda>n. exp (h_ub n)) sums ((exp(-(2*?p+1))/(1-exp(-1))) + sum (\<lambda>n. exp (h_ub n)) {..<2*n})"
    by (intro iffD1[OF sums_iff_shift])
  hence a:"(\<lambda>n. exp (h_ub n)) sums sum_h_ub"
    unfolding sum_h_ub_def h_ub_def by (simp add:algebra_simps)

  have h_deriv: "(h has_real_derivative (h' x)) (at y)" if "x > 0" "y = x" for x y
    unfolding h_def h'_def using that
    by (auto intro!: derivative_eq_intros)

  have h'_ge_0: "h' x \<ge> 0" if "x \<le> x0" "x \<ge> 1" for x
  proof -
    have "ln x * x \<le> ln x0 * x0"
      using that by (intro mult_mono iffD2[OF ln_le_cancel_iff]) auto
    also have "... = ?p"
      using eqn_24 by (simp add:algebra_simps)
    finally have "ln x * x \<le> ?p" by simp
    thus ?thesis
      using that unfolding h'_def by (simp add: mult_imp_le_div_pos)
  qed
  hence "\<exists>y. (h has_real_derivative y) (at x) \<and> y \<ge> 0" if "x \<le> x0" "x \<ge> 1" for x
    using that x0_ge_1 by (intro exI[where x="h' x"] h_deriv conjI) auto
  hence h_max_1: "h x \<le> h x0" if "x \<le> x0" " x\<ge>1" for x
    using  that
    by (intro DERIV_nonneg_imp_nondecreasing[OF that(1)]) simp

  have "h' x \<le> 0" if "x \<ge> x0" for x
  proof -
    have "?p = ln x0 * x0"
      using eqn_24 by (simp add:algebra_simps)
    also have "... \<le> ln x * x"
      using that x0_ge_1 by (intro mult_mono iffD2[OF ln_le_cancel_iff]) auto
    finally have "?p \<le> ln x * x" by simp
    thus ?thesis
      using that x0_ge_1 unfolding h'_def by (simp add:pos_divide_le_eq)
  qed
  hence "\<exists>y. (h has_real_derivative y) (at x) \<and> y \<le> 0" if "x \<ge> x0" for x
    using that x0_ge_1 by (intro exI[where x="h' x"] h_deriv conjI) auto
  hence h_max_2: "h x0 \<ge> h x" if "x0 \<le> x" for x
    by (intro DERIV_nonpos_imp_nonincreasing[OF that])

  have h_max: "h x \<le> h x0" if "x \<ge> 1" for x
    using h_max_1 h_max_2 that by (cases "x \<ge> x0") auto

  text \<open>The following block corresponds to Eq. 29.\<close>
  have eqn_29: "h x \<le> h_max" if "x \<ge> 1" for x
  proof -
    have "h x \<le> h x0"
      using that by (intro h_max) auto
    also have "... = x0 + ?p * ln x0 - ?p"
      unfolding h_def eqn_24 by (simp add:algebra_simps)
    also have "... \<le> \<alpha> * ?p / ln ?p + ?p * ln (\<alpha> * ?p / ln ?p) - ?p"
      using that assms x0_ge_1 \<alpha>_gt_1
      by (intro add_mono diff_mono eqn_25 mult_mono iffD2[OF ln_le_cancel_iff]) auto
    also have "... = \<alpha> * ?p / ln ?p  + ?p * ln ?p - ?p * ln (ln ?p) + ?p * (ln \<alpha> - 1)"
      using assms \<alpha>_gt_1 by (simp add: ln_div ln_mult algebra_simps)
    also have "... = ?p * (\<alpha> / ln ?p + ln ?p - ln (ln (?p)) + (ln \<alpha> - 1))"
      by (simp add:algebra_simps)
    also have "... = ?p * (bell_approx_d ?p + ln ?p - ln (ln (?p + 1)) + ln \<alpha> - 1)"
      unfolding bell_approx_d_def \<alpha>_def by (simp add:exp_minus inverse_eq_divide)
    also have "... \<le> ?p * (\<epsilon> + ln ?p - ln (ln (?p + 1)) + ln \<alpha> - 1)" (* 29 *)
      by (intro mult_left_mono add_mono diff_mono assms(1)) simp_all
    also have "... = h_max" unfolding h_max_def by simp
    finally show ?thesis by simp
  qed

  text \<open>The following block corresponds to Eq. 30.\<close>
  have eqn_30: "h x \<le> - x" if "x \<ge> 2*?p" for x
  proof -
    have "exp 4 \<le> 2*?p" using assms apx by simp
    also have "... \<le> x" using that by simp
    finally have eqn_30_1:  "exp 4 \<le> x" by simp

    have "h x = x - (x - ?p) * ln x"
      unfolding h_def by (simp add:algebra_simps)
    also have "... \<le> x - (x - x/2) * ln x"
      using assms(2) that by (intro diff_mono mult_right_mono) auto
    also have "... \<le> x - (x/2) * ln x"  by simp
    also have "... \<le> x - (x/2) * 4"
      using that assms
      by (intro diff_mono mult_left_mono iffD2[OF ln_ge_iff] eqn_30_1) auto
    also have "... = - x" by simp
    finally show ?thesis by simp
  qed

  have b: "real (Suc k) ^ n / fact (Suc k) \<le> exp (h_ub k)"
    (is "?L1 \<le> ?R1")  for k
  proof -
    define sk where "sk = (Suc k)"
    have sk_gt_0: "sk > 0" unfolding sk_def by simp
    have "?L1 \<le> real sk ^ n / (real sk / exp(1))^(sk)"
      unfolding sk_def
      by (intro divide_left_mono fact_lower_bound_1) auto
    also have "... = real sk ^ n * exp(1)^sk / real sk^sk"
      by (simp add:power_divide)
    also have "... = exp (ln (real sk ^ n * exp(1)^sk / real sk^sk))"
      using sk_gt_0 assms(2) by (subst exp_ln) auto
    also have "... = exp ( h(real sk))"
      unfolding h_def
      using sk_gt_0 assms(2) by (simp add: ln_div ln_mult ln_realpow)
    also have "... = exp (h (real (Suc k)))"
      unfolding sk_def by simp
    also have "... \<le> exp (h_ub k)"
      using eqn_29[where x="real (Suc k)"] eqn_30[where x="real (Suc k)"]
      unfolding  h_ub_def by (simp add:not_less)
    finally show ?thesis by simp
  qed

  have "exp(-1) = exp(-1) * 1" by simp
  also have "... \<le> exp(-0.6+\<epsilon>) * (?p / ln (1+?p))"
    using \<epsilon>_ge_0 assms
    by (intro mult_mono iffD2[OF pos_le_divide_eq])
     (auto simp add:ln_add_one_self_le_self)
  also have "... = exp (-0.6 + \<epsilon>) * ?p / ln (?p + 1)" by simp
  finally have c: "exp (-1) \<le> exp (-0.6 + \<epsilon>) * ?p / ln (?p + 1)" by simp

  text \<open>The following block corresponds to Eq.~32 and 33.\<close>
  have "sum_h_ub \<le> (2 * ?p) * exp(h_max)  + exp(-(2*?p)) * (exp(-1)/(1-exp(-1)))"
    unfolding sum_h_ub_def by (simp add:exp_add[symmetric])
  also have "... \<le> (2 * ?p) * exp(h_max) + exp(-(2*?p)) * 1"
    using apx by (intro add_mono mult_left_mono) auto
  also have "... = ((2 * real n) powr (1/n)) powr n *
    (exp (ln (?p) - ln (ln (?p + 1)) + (\<epsilon> + ln \<alpha> - 1))) powr n + exp (- (2*?p))"
    unfolding h_max_def exp_powr by (simp add:algebra_simps powr_powr)
  also have "... = ((2 * ?p) powr (1/n)) powr n *
    (n / ln (?p+1) * exp ((\<epsilon> + ln \<alpha> - 1))) powr n + exp (- (2 * ?p))"
    using assms by (simp add: exp_add exp_diff algebra_simps)
  also have "... = ((2 * ?p) powr (1/?p) * ((n / ln (?p+1) * exp ((\<epsilon> + ln \<alpha> - 1))))) powr n
    + exp (- (2 * ?p))"
    by (subst powr_mult[symmetric]) auto
  also have "... = (2 powr (1/?p) * ?p powr (1/?p) *
    ((n / ln (?p+1) * exp (\<epsilon>+ln \<alpha>-1)))) powr n + exp (- (2 * ?p))"
    by (simp add:powr_mult)
  also have "... = (2 powr (1/?p) * exp (ln(?p)/?p) *
    ((n / ln (?p+1) * exp (\<epsilon>+ln \<alpha>-1)))) powr n + exp (- (2 * ?p))"
    by (simp add:powr_def)
  also have "... \<le> (2 powr (1/55) * exp (ln(55)/55) *
    ((n / ln (?p+1) * exp (\<epsilon>+ln \<alpha>-1)))) powr n + exp (- (2 * ?p))"
    using assms apx by (intro add_mono powr_mono2 mult_mono
        iffD2[OF exp_le_cancel_iff] ln_x_over_x_mono) auto
  also have "... = (n / ln (?p+1) *
    exp (\<epsilon> + (ln (1+1/exp 1) - 1 + (ln (55) + ln(2)) / 55))) powr n + exp (- (2 * ?p))"
    by (simp add:powr_def exp_add[symmetric] \<alpha>_def)
  also have "... \<le> (n / ln (?p+1) * exp (\<epsilon> + (-0.6007))) powr n + exp (-(2*?p))"
    using apx by (intro add_mono powr_mono2 mult_left_mono iffD2[OF exp_le_cancel_iff]) auto
  text \<open>The following block corresponds to Eq.~35.\<close>
  also have "... = (exp (-0.6007+\<epsilon>) * n / ln (?p+1)) powr n + exp(-2*?p)"
    by (simp add:algebra_simps)
  also have "... = ?R * exp(-0.0007) powr n + exp(-1) powr n *exp(-n)"
    by (subst powr_mult[symmetric])
      (auto simp add:algebra_simps exp_add[symmetric] exp_powr)
  also have "... \<le> ?R * exp(-0.0007) powr 55 + exp(-1) powr n *exp(-55)"
    using assms by (intro add_mono mult_left_mono powr_mono_rev) auto
  also have "... < ?R * 0.97 + exp(-1) powr n * 0.03"
    using assms(2)
    by (intro add_less_le_mono mult_strict_left_mono mult_left_mono apx) auto
  also have "... \<le> ?R * 0.97 + ?R * 0.03"
    by (intro add_mono mult_right_mono powr_mono2 c) auto
  also have "... = ?R" by simp
  finally have d: "sum_h_ub < ?R" by simp

  have "?L = 1 * real (Bell n)" by simp
    also have "... \<le> exp 1 * Bell n"
    by (intro mult_right_mono) auto
  also have "... \<le> sum_h_ub"
    by (intro sums_le[OF b dobinski_suc a])
  also have "... < ?R"
    by (intro d)
  finally show ?thesis by simp
qed

subsection \<open>Approximation for all numbers\<close>

text \<open>Berend and Tassa also show an approximate formula that is true for all
Bell numbers~\cite[Theorem 2.1]{berend2010}:
\[
  B_n \leq \left( \frac{0.792 n}{ \ln (n+1)} \right)^n
\]
Their proof uses the previous result for $n \geq 55$, and for the cases $n=0,\ldots,54$ the
formula is verified explicitly.\<close>

theorem bell_approx_2: "real (Bell n) \<le> (0.792 * n / ln (n + 1)) ^ n"
proof -
  consider
    (i) "n = 0" | (ii) "n \<ge> 1 \<and> n \<le> 54" | (iii) "n \<ge> 55"
    by linarith
  then show ?thesis
  proof cases
    case i
    then show ?thesis by (simp add:Bell_0)
  next
    case ii

    define bell_init_seg
      where "bell_init_seg = drop 1 (List.enumerate 0 (bell_list 54))"

    define condition :: "(nat \<times> nat \<Rightarrow> bool)"
      where "condition = (\<lambda>(k, v). real v < (0.792 * k / ln (real k + 1)) powr k)"

    have filter_empty_intros:
      "filter P xs = [] \<Longrightarrow> \<not>(P x) \<Longrightarrow> filter P (x#xs) = []"
      "filter P [] = []" for x xs and P :: "nat \<times> nat \<Rightarrow> bool"
      by auto

    have a:"[] = filter (Not \<circ> condition) bell_init_seg"
      unfolding bell_init_seg_def
      apply normalization
      apply (intro filter_empty_intros)
      by (simp add:condition_def not_le del:powr_numeral, approximation 15)+

    have "bell_init_seg = List.enumerate 1 (map Bell [1..<55])"
      unfolding bell_init_seg_def bell_list_eq enumerate_eq_zip drop_zip drop_map
      by simp
    hence "set bell_init_seg = {i. fst i \<ge> 1 \<and> fst i < 55 \<and> snd i = Bell (fst i)}"
      by (intro iffD2[OF set_eq_iff] allI) (auto simp add:in_set_enumerate_eq)
    hence "(n, Bell n) \<in> set bell_init_seg"
      using ii by simp
    hence "condition (n, Bell n)"
      using a by (simp add: empty_filter_conv)

    then show ?thesis
      using ii unfolding condition_def by (simp add: powr_realpow)
  next
    case iii
    define \<epsilon> :: real where "\<epsilon> = ln 0.792 + 0.6"
    have "bell_approx_d n \<le> bell_approx_d 55"
      using iii by (intro bell_approx_d_decreasing) auto
    also have "... \<le> \<epsilon>"
      unfolding bell_approx_d_def \<epsilon>_def by (approximation 10)
    finally have "bell_approx_d n \<le> \<epsilon>" by simp
    hence "real (Bell n) < (exp (-0.6+\<epsilon>) * n / ln (real n + 1)) powr n"
      using iii by (intro bell_approx_1) auto
    also have "... = (0.792 * n / ln (real n + 1)) ^ n"
      using iii unfolding \<epsilon>_def
      by (subst powr_realpow, auto)
    finally show ?thesis by simp
  qed
qed

end


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

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for the least significant bit\<close>

theory Least_significant_bit
  imports
    "HOL-Library.Word"
    Bits_Int
begin

class lsb = semiring_bits +
  fixes lsb :: \<open>'a \<Rightarrow> bool\<close>
  assumes lsb_odd: \<open>lsb = odd\<close>

instantiation int :: lsb
begin

definition lsb_int :: \<open>int \<Rightarrow> bool\<close>
  where \<open>lsb i = i !! 0\<close> for i :: int

instance
  by standard (simp add: fun_eq_iff lsb_int_def)

end

lemma bin_last_conv_lsb: "bin_last = lsb"
  by (simp add: lsb_odd)

lemma int_lsb_numeral [simp]:
  "lsb (0 :: int) = False"
  "lsb (1 :: int) = True"
  "lsb (Numeral1 :: int) = True"
  "lsb (- 1 :: int) = True"
  "lsb (- Numeral1 :: int) = True"
  "lsb (numeral (num.Bit0 w) :: int) = False"
  "lsb (numeral (num.Bit1 w) :: int) = True"
  "lsb (- numeral (num.Bit0 w) :: int) = False"
  "lsb (- numeral (num.Bit1 w) :: int) = True"
  by (simp_all add: lsb_int_def)

instantiation word :: (len) lsb
begin

definition lsb_word :: \<open>'a word \<Rightarrow> bool\<close>
  where word_lsb_def: \<open>lsb a \<longleftrightarrow> odd (uint a)\<close> for a :: \<open>'a word\<close>

instance
  apply standard
  apply (simp add: fun_eq_iff word_lsb_def)
  apply transfer apply simp
  done

end

lemma lsb_word_eq:
  \<open>lsb = (odd :: 'a word \<Rightarrow> bool)\<close> for w :: \<open>'a::len word\<close>
  by (fact lsb_odd)

lemma word_lsb_alt: "lsb w = test_bit w 0"
  for w :: "'a::len word"
  by (auto simp: word_test_bit_def word_lsb_def)

lemma word_lsb_1_0 [simp]: "lsb (1::'a::len word) \<and> \<not> lsb (0::'b::len word)"
  unfolding word_lsb_def by simp

lemma word_lsb_int: "lsb w \<longleftrightarrow> uint w mod 2 = 1"
  apply (simp add: lsb_odd flip: odd_iff_mod_2_eq_one)
  apply transfer
  apply simp
  done

lemmas word_ops_lsb = lsb0 [unfolded word_lsb_alt]

lemma word_lsb_numeral [simp]:
  "lsb (numeral bin :: 'a::len word) \<longleftrightarrow> bin_last (numeral bin)"
  unfolding word_lsb_alt test_bit_numeral by simp

lemma word_lsb_neg_numeral [simp]:
  "lsb (- numeral bin :: 'a::len word) \<longleftrightarrow> bin_last (- numeral bin)"
  by (simp add: word_lsb_alt)

lemma word_lsb_nat:"lsb w = (unat w mod 2 = 1)"
  apply (simp add: word_lsb_def Groebner_Basis.algebra(31))
  apply transfer
  apply (simp add: even_nat_iff)
  done

end


(*  Title:      HOL/Probability/Projective_Family.thy
    Author:     Fabian Immler, TU München
    Author:     Johannes Hölzl, TU München
*)

section \<open>Projective Family\<close>

theory Projective_Family
imports Giry_Monad
begin

lemma vimage_restrict_preseve_mono:
  assumes J: "J \<subseteq> I"
  and sets: "A \<subseteq> (\<Pi>\<^sub>E i\<in>J. S i)" "B \<subseteq> (\<Pi>\<^sub>E i\<in>J. S i)" and ne: "(\<Pi>\<^sub>E i\<in>I. S i) \<noteq> {}"
  and eq: "(\<lambda>x. restrict x J) -` A \<inter> (\<Pi>\<^sub>E i\<in>I. S i) \<subseteq> (\<lambda>x. restrict x J) -` B \<inter> (\<Pi>\<^sub>E i\<in>I. S i)"
  shows "A \<subseteq> B"
proof  (intro subsetI)
  fix x assume "x \<in> A"
  from ne obtain y where y: "\<And>i. i \<in> I \<Longrightarrow> y i \<in> S i" by auto
  have "J \<inter> (I - J) = {}" by auto
  show "x \<in> B"
  proof cases
    assume x: "x \<in> (\<Pi>\<^sub>E i\<in>J. S i)"
    have "merge J (I - J) (x,y) \<in> (\<lambda>x. restrict x J) -` A \<inter> (\<Pi>\<^sub>E i\<in>I. S i)"
      using y x \<open>J \<subseteq> I\<close> PiE_cancel_merge[of "J" "I - J" x y S] \<open>x\<in>A\<close>
      by (auto simp del: PiE_cancel_merge simp add: Un_absorb1)
    also have "\<dots> \<subseteq> (\<lambda>x. restrict x J) -` B \<inter> (\<Pi>\<^sub>E i\<in>I. S i)" by fact
    finally show "x \<in> B"
      using y x \<open>J \<subseteq> I\<close> PiE_cancel_merge[of "J" "I - J" x y S] \<open>x\<in>A\<close> eq
      by (auto simp del: PiE_cancel_merge simp add: Un_absorb1)
  qed (insert \<open>x\<in>A\<close> sets, auto)
qed

locale projective_family =
  fixes I :: "'i set" and P :: "'i set \<Rightarrow> ('i \<Rightarrow> 'a) measure" and M :: "'i \<Rightarrow> 'a measure"
  assumes P: "\<And>J H. J \<subseteq> H \<Longrightarrow> finite H \<Longrightarrow> H \<subseteq> I \<Longrightarrow> P J = distr (P H) (PiM J M) (\<lambda>f. restrict f J)"
  assumes prob_space_P: "\<And>J. finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> prob_space (P J)"
begin

lemma sets_P: "finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> sets (P J) = sets (PiM J M)"
  by (subst P[of J J]) simp_all

lemma space_P: "finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> space (P J) = space (PiM J M)"
  using sets_P by (rule sets_eq_imp_space_eq)

lemma not_empty_M: "i \<in> I \<Longrightarrow> space (M i) \<noteq> {}"
  using prob_space_P[THEN prob_space.not_empty] by (auto simp: space_PiM space_P)

lemma not_empty: "space (PiM I M) \<noteq> {}"
  by (simp add: not_empty_M)

abbreviation
  "emb L K \<equiv> prod_emb L M K"

lemma emb_preserve_mono:
  assumes "J \<subseteq> L" "L \<subseteq> I" and sets: "X \<in> sets (Pi\<^sub>M J M)" "Y \<in> sets (Pi\<^sub>M J M)"
  assumes "emb L J X \<subseteq> emb L J Y"
  shows "X \<subseteq> Y"
proof (rule vimage_restrict_preseve_mono)
  show "X \<subseteq> (\<Pi>\<^sub>E i\<in>J. space (M i))" "Y \<subseteq> (\<Pi>\<^sub>E i\<in>J. space (M i))"
    using sets[THEN sets.sets_into_space] by (auto simp: space_PiM)
  show "(\<Pi>\<^sub>E i\<in>L. space (M i)) \<noteq> {}"
    using \<open>L \<subseteq> I\<close> by (auto simp add: not_empty_M space_PiM[symmetric])
  show "(\<lambda>x. restrict x J) -` X \<inter> (\<Pi>\<^sub>E i\<in>L. space (M i)) \<subseteq> (\<lambda>x. restrict x J) -` Y \<inter> (\<Pi>\<^sub>E i\<in>L. space (M i))"
    using \<open>prod_emb L M J X \<subseteq> prod_emb L M J Y\<close> by (simp add: prod_emb_def)
qed fact

lemma emb_injective:
  assumes L: "J \<subseteq> L" "L \<subseteq> I" and X: "X \<in> sets (Pi\<^sub>M J M)" and Y: "Y \<in> sets (Pi\<^sub>M J M)"
  shows "emb L J X = emb L J Y \<Longrightarrow> X = Y"
  by (intro antisym emb_preserve_mono[OF L X Y] emb_preserve_mono[OF L Y X]) auto

lemma emeasure_P: "J \<subseteq> K \<Longrightarrow> finite K \<Longrightarrow> K \<subseteq> I \<Longrightarrow> X \<in> sets (PiM J M) \<Longrightarrow> P K (emb K J X) = P J X"
  by (auto intro!: emeasure_distr_restrict[symmetric] simp: P sets_P)

inductive_set generator :: "('i \<Rightarrow> 'a) set set" where
  "finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> X \<in> sets (Pi\<^sub>M J M) \<Longrightarrow> emb I J X \<in> generator"

lemma algebra_generator: "algebra (space (PiM I M)) generator"
  unfolding algebra_iff_Int
proof (safe elim!: generator.cases)
  fix J X assume J: "finite J" "J \<subseteq> I" and X: "X \<in> sets (PiM J M)"

  from X[THEN sets.sets_into_space] J show "x \<in> emb I J X \<Longrightarrow> x \<in> space (PiM I M)" for x
    by (auto simp: prod_emb_def space_PiM)

  have "emb I J (space (PiM J M) - X) \<in> generator"
    by (intro generator.intros J sets.Diff sets.top X)
  with J show "space (Pi\<^sub>M I M) - emb I J X \<in> generator"
    by (simp add: space_PiM prod_emb_PiE)

  fix K Y assume K: "finite K" "K \<subseteq> I" and Y: "Y \<in> sets (PiM K M)"
  have "emb I (J \<union> K) (emb (J \<union> K) J X) \<inter> emb I (J \<union> K) (emb (J \<union> K) K Y) \<in> generator"
    unfolding prod_emb_Int[symmetric]
    by (intro generator.intros sets.Int measurable_prod_emb) (auto intro!: J K X Y)
  with J K X Y show "emb I J X \<inter> emb I K Y \<in> generator"
    by simp
qed (force simp: generator.simps prod_emb_empty[symmetric])

interpretation generator: algebra "space (PiM I M)" generator
  by (rule algebra_generator)

lemma sets_PiM_generator: "sets (PiM I M) = sigma_sets (space (PiM I M)) generator"
proof (intro antisym sets.sigma_sets_subset)
  show "sets (PiM I M) \<subseteq> sigma_sets (space (PiM I M)) generator"
    unfolding sets_PiM_single space_PiM[symmetric]
  proof (intro sigma_sets_mono', safe)
    fix i A assume "i \<in> I" and A: "A \<in> sets (M i)"
    then have "{f \<in> space (Pi\<^sub>M I M). f i \<in> A} = emb I {i} (\<Pi>\<^sub>E j\<in>{i}. A)"
      by (auto simp: prod_emb_def space_PiM restrict_def Pi_iff PiE_iff extensional_def)
    with \<open>i\<in>I\<close> A show "{f \<in> space (Pi\<^sub>M I M). f i \<in> A} \<in> generator"
      by (auto intro!: generator.intros sets_PiM_I_finite)
  qed
qed (auto elim!: generator.cases)

definition mu_G ("\<mu>G") where
  "\<mu>G A = (THE x. \<forall>J\<subseteq>I. finite J \<longrightarrow> (\<forall>X\<in>sets (Pi\<^sub>M J M). A = emb I J X \<longrightarrow> x = emeasure (P J) X))"

definition lim :: "('i \<Rightarrow> 'a) measure" where
  "lim = extend_measure (space (PiM I M)) generator (\<lambda>x. x) \<mu>G"

lemma space_lim[simp]: "space lim = space (PiM I M)"
  using generator.space_closed
  unfolding lim_def by (intro space_extend_measure) simp

lemma sets_lim[simp, measurable]: "sets lim = sets (PiM I M)"
  using generator.space_closed by (simp add: lim_def sets_PiM_generator sets_extend_measure)

lemma mu_G_spec:
  assumes J: "finite J" "J \<subseteq> I" "X \<in> sets (Pi\<^sub>M J M)"
  shows "\<mu>G (emb I J X) = emeasure (P J) X"
  unfolding mu_G_def
proof (intro the_equality allI impI ballI)
  fix K Y assume K: "finite K" "K \<subseteq> I" "Y \<in> sets (Pi\<^sub>M K M)"
    and [simp]: "emb I J X = emb I K Y"
  have "emeasure (P K) Y = emeasure (P (K \<union> J)) (emb (K \<union> J) K Y)"
    using K J by (simp add: emeasure_P)
  also have "emb (K \<union> J) K Y = emb (K \<union> J) J X"
    using K J by (simp add: emb_injective[of "K \<union> J" I])
  also have "emeasure (P (K \<union> J)) (emb (K \<union> J) J X) = emeasure (P J) X"
    using K J by (subst emeasure_P) simp_all
  finally show "emeasure (P J) X = emeasure (P K) Y" ..
qed (insert J, force)

lemma positive_mu_G: "positive generator \<mu>G"
proof -
  show ?thesis
  proof (safe intro!: positive_def[THEN iffD2])
    obtain J where "finite J" "J \<subseteq> I" by auto
    then have "\<mu>G (emb I J {}) = 0"
      by (subst mu_G_spec) auto
    then show "\<mu>G {} = 0" by simp
  qed
qed

lemma additive_mu_G: "additive generator \<mu>G"
proof (safe intro!: additive_def[THEN iffD2] elim!: generator.cases)
  fix J X K Y assume J: "finite J" "J \<subseteq> I" "X \<in> sets (PiM J M)"
    and K: "finite K" "K \<subseteq> I" "Y \<in> sets (PiM K M)"
    and "emb I J X \<inter> emb I K Y = {}"
  then have JK_disj: "emb (J \<union> K) J X \<inter> emb (J \<union> K) K Y = {}"
    by (intro emb_injective[of "J \<union> K" I _ "{}"]) (auto simp: sets.Int prod_emb_Int)
  have "\<mu>G (emb I J X \<union> emb I K Y) = \<mu>G (emb I (J \<union> K) (emb (J \<union> K) J X \<union> emb (J \<union> K) K Y))"
    using J K by simp
  also have "\<dots> = emeasure (P (J \<union> K)) (emb (J \<union> K) J X \<union> emb (J \<union> K) K Y)"
    using J K by (simp add: mu_G_spec sets.Un del: prod_emb_Un)
  also have "\<dots> = \<mu>G (emb I J X) + \<mu>G (emb I K Y)"
    using J K JK_disj by (simp add: plus_emeasure[symmetric] mu_G_spec emeasure_P sets_P)
  finally show "\<mu>G (emb I J X \<union> emb I K Y) = \<mu>G (emb I J X) + \<mu>G (emb I K Y)" .
qed

lemma emeasure_lim:
  assumes JX: "finite J" "J \<subseteq> I" "X \<in> sets (PiM J M)"
  assumes cont: "\<And>J X. (\<And>i. J i \<subseteq> I) \<Longrightarrow> incseq J \<Longrightarrow> (\<And>i. finite (J i)) \<Longrightarrow> (\<And>i. X i \<in> sets (PiM (J i) M)) \<Longrightarrow>
    decseq (\<lambda>i. emb I (J i) (X i)) \<Longrightarrow> 0 < (INF i. P (J i) (X i)) \<Longrightarrow> (\<Inter>i. emb I (J i) (X i)) \<noteq> {}"
  shows "emeasure lim (emb I J X) = P J X"
proof -
  have "\<exists>\<mu>. (\<forall>s\<in>generator. \<mu> s = \<mu>G s) \<and>
    measure_space (space (PiM I M)) (sigma_sets (space (PiM I M)) generator) \<mu>"
  proof (rule generator.caratheodory_empty_continuous[OF positive_mu_G additive_mu_G])
    show "\<And>A. A \<in> generator \<Longrightarrow> \<mu>G A \<noteq> \<infinity>"
    proof (clarsimp elim!: generator.cases simp: mu_G_spec del: notI)
      fix J assume "finite J" "J \<subseteq> I"
      then interpret prob_space "P J" by (rule prob_space_P)
      show "\<And>X. X \<in> sets (Pi\<^sub>M J M) \<Longrightarrow> emeasure (P J) X \<noteq> top"
        by simp
    qed
  next
    fix A assume "range A \<subseteq> generator" and "decseq A" "(\<Inter>i. A i) = {}"
    then have "\<forall>i. \<exists>J X. A i = emb I J X \<and> finite J \<and> J \<subseteq> I \<and> X \<in> sets (PiM J M)"
      unfolding image_subset_iff generator.simps by blast
    then obtain J X where A: "\<And>i. A i = emb I (J i) (X i)"
      and *: "\<And>i. finite (J i)" "\<And>i. J i \<subseteq> I" "\<And>i. X i \<in> sets (PiM (J i) M)"
      by metis
    have "(INF i. P (J i) (X i)) = 0"
    proof (rule ccontr)
      assume INF_P: "(INF i. P (J i) (X i)) \<noteq> 0"
      have "(\<Inter>i. emb I (\<Union>n\<le>i. J n) (emb (\<Union>n\<le>i. J n) (J i) (X i))) \<noteq> {}"
      proof (rule cont)
        show "decseq (\<lambda>i. emb I (\<Union>n\<le>i. J n) (emb (\<Union>n\<le>i. J n) (J i) (X i)))"
          using * \<open>decseq A\<close> by (subst prod_emb_trans) (auto simp: A[abs_def])
        show "0 < (INF i. P (\<Union>n\<le>i. J n) (emb (\<Union>n\<le>i. J n) (J i) (X i)))"
           using * INF_P by (subst emeasure_P) (auto simp: less_le intro!: INF_greatest)
        show "incseq (\<lambda>i. \<Union>n\<le>i. J n)"
          by (force simp: incseq_def)
      qed (insert *, auto)
      with \<open>(\<Inter>i. A i) = {}\<close> * show False
        by (subst (asm) prod_emb_trans) (auto simp: A[abs_def])
    qed
    moreover have "(\<lambda>i. P (J i) (X i)) \<longlonglongrightarrow> (INF i. P (J i) (X i))"
    proof (intro LIMSEQ_INF antimonoI)
      fix x y :: nat assume "x \<le> y"
      have "P (J y \<union> J x) (emb (J y \<union> J x) (J y) (X y)) \<le> P (J y \<union> J x) (emb (J y \<union> J x) (J x) (X x))"
        using \<open>decseq A\<close>[THEN decseqD, OF \<open>x\<le>y\<close>] *
        by (auto simp: A sets_P del: subsetI intro!: emeasure_mono  \<open>x \<le> y\<close>
              emb_preserve_mono[of "J y \<union> J x" I, where X="emb (J y \<union> J x) (J y) (X y)"])
      then show "P (J y) (X y) \<le> P (J x) (X x)"
        using * by (simp add: emeasure_P)
    qed
    ultimately show "(\<lambda>i. \<mu>G (A i)) \<longlonglongrightarrow> 0"
      by (auto simp: A[abs_def] mu_G_spec *)
  qed
  then obtain \<mu> where eq: "\<forall>s\<in>generator. \<mu> s = \<mu>G s"
    and ms: "measure_space (space (PiM I M)) (sets (PiM I M)) \<mu>"
    by (metis sets_PiM_generator)
  show ?thesis
  proof (subst emeasure_extend_measure[OF lim_def])
    show "A \<in> generator \<Longrightarrow> \<mu> A = \<mu>G A" for A
      using eq by simp
    show "positive (sets lim) \<mu>" "countably_additive (sets lim) \<mu>"
      using ms by (auto simp add: measure_space_def)
    show "(\<lambda>x. x) ` generator \<subseteq> Pow (space (Pi\<^sub>M I M))"
      using generator.space_closed by simp
    show "emb I J X \<in> generator" "\<mu>G (emb I J X) = emeasure (P J) X"
      using JX by (auto intro: generator.intros simp: mu_G_spec)
  qed
qed

end

sublocale product_prob_space \<subseteq> projective_family I "\<lambda>J. PiM J M" M
  unfolding projective_family_def
proof (intro conjI allI impI distr_restrict)
  show "\<And>J. finite J \<Longrightarrow> prob_space (Pi\<^sub>M J M)"
    by (intro prob_spaceI) (simp add: space_PiM emeasure_PiM emeasure_space_1)
qed auto

txt \<open> Proof due to Ionescu Tulcea. \<close>

locale Ionescu_Tulcea =
  fixes P :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a measure" and M :: "nat \<Rightarrow> 'a measure"
  assumes P[measurable]: "\<And>i. P i \<in> measurable (PiM {0..<i} M) (subprob_algebra (M i))"
  assumes prob_space_P: "\<And>i x. x \<in> space (PiM {0..<i} M) \<Longrightarrow> prob_space (P i x)"
begin

lemma non_empty[simp]: "space (M i) \<noteq> {}"
proof (induction i rule: less_induct)
  case (less i)
  then obtain x where "\<And>j. j < i \<Longrightarrow> x j \<in> space (M j)"
    unfolding ex_in_conv[symmetric] by metis
  then have *: "restrict x {0..<i} \<in> space (PiM {0..<i} M)"
    by (auto simp: space_PiM PiE_iff)
  then interpret prob_space "P i (restrict x {0..<i})"
    by (rule prob_space_P)
  show ?case
    using not_empty subprob_measurableD(1)[OF P, OF *] by simp
qed

lemma space_PiM_not_empty[simp]: "space (PiM UNIV M) \<noteq> {}"
  unfolding space_PiM_empty_iff by auto

lemma space_P: "x \<in> space (PiM {0..<n} M) \<Longrightarrow> space (P n x) = space (M n)"
  by (simp add: P[THEN subprob_measurableD(1)])

lemma sets_P[measurable_cong]: "x \<in> space (PiM {0..<n} M) \<Longrightarrow> sets (P n x) = sets (M n)"
  by (simp add: P[THEN subprob_measurableD(2)])

definition eP :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) measure" where
  "eP n \<omega> = distr (P n \<omega>) (PiM {0..<Suc n} M) (fun_upd \<omega> n)"

lemma measurable_eP[measurable]:
  "eP n \<in> measurable (PiM {0..< n} M) (subprob_algebra (PiM {0..<Suc n} M))"
  by (auto simp: eP_def[abs_def] measurable_split_conv
           intro!: measurable_fun_upd[where J="{0..<n}"] measurable_distr2[OF _ P])

lemma space_eP:
  "x \<in> space (PiM {0..<n} M) \<Longrightarrow> space (eP n x) = space (PiM {0..<Suc n} M)"
  by (simp add: measurable_eP[THEN subprob_measurableD(1)])

lemma sets_eP[measurable]:
  "x \<in> space (PiM {0..<n} M) \<Longrightarrow> sets (eP n x) = sets (PiM {0..<Suc n} M)"
  by (simp add: measurable_eP[THEN subprob_measurableD(2)])

lemma prob_space_eP: "x \<in> space (PiM {0..<n} M) \<Longrightarrow> prob_space (eP n x)"
  unfolding eP_def
  by (intro prob_space.prob_space_distr prob_space_P measurable_fun_upd[where J="{0..<n}"]) auto

lemma nn_integral_eP:
  "\<omega> \<in> space (PiM {0..<n} M) \<Longrightarrow> f \<in> borel_measurable (PiM {0..<Suc n} M) \<Longrightarrow>
    (\<integral>\<^sup>+x. f x \<partial>eP n \<omega>) = (\<integral>\<^sup>+x. f (\<omega>(n := x)) \<partial>P n \<omega>)"
  unfolding eP_def
  by (subst nn_integral_distr) (auto intro!: measurable_fun_upd[where J="{0..<n}"] simp: space_PiM PiE_iff)

lemma emeasure_eP:
  assumes \<omega>[simp]: "\<omega> \<in> space (PiM {0..<n} M)" and A[measurable]: "A \<in> sets (PiM {0..<Suc n} M)"
  shows "eP n \<omega> A = P n \<omega> ((\<lambda>x. \<omega>(n := x)) -` A \<inter> space (M n))"
  using nn_integral_eP[of \<omega> n "indicator A"]
  apply (simp add: sets_eP nn_integral_indicator[symmetric] sets_P del: nn_integral_indicator)
  apply (subst nn_integral_indicator[symmetric])
  using measurable_sets[OF measurable_fun_upd[OF _ measurable_const[OF \<omega>] measurable_id] A, of n]
  apply (auto simp add: sets_P atLeastLessThanSuc space_P simp del: nn_integral_indicator
     intro!: nn_integral_cong split: split_indicator)
  done

primrec C :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) measure" where
  "C n 0 \<omega> = return (PiM {0..<n} M) \<omega>"
| "C n (Suc m) \<omega> = C n m \<omega> \<bind> eP (n + m)"

lemma measurable_C[measurable]:
  "C n m \<in> measurable (PiM {0..<n} M) (subprob_algebra (PiM {0..<n + m} M))"
  by (induction m) auto

lemma space_C:
  "x \<in> space (PiM {0..<n} M) \<Longrightarrow> space (C n m x) = space (PiM {0..<n + m} M)"
  by (simp add: measurable_C[THEN subprob_measurableD(1)])

lemma sets_C[measurable_cong]:
  "x \<in> space (PiM {0..<n} M) \<Longrightarrow> sets (C n m x) = sets (PiM {0..<n + m} M)"
  by (simp add: measurable_C[THEN subprob_measurableD(2)])

lemma prob_space_C: "x \<in> space (PiM {0..<n} M) \<Longrightarrow> prob_space (C n m x)"
proof (induction m)
  case (Suc m) then show ?case
    by (auto intro!: prob_space.prob_space_bind[where S="PiM {0..<Suc (n + m)} M"]
             simp: space_C prob_space_eP)
qed (auto intro!: prob_space_return simp: space_PiM)

lemma split_C:
  assumes \<omega>: "\<omega> \<in> space (PiM {0..<n} M)" shows "(C n m \<omega> \<bind> C (n + m) l) = C n (m + l) \<omega>"
proof (induction l)
  case 0
  with \<omega> show ?case
    by (simp add: bind_return_distr' prob_space_C[THEN prob_space.not_empty]
                  distr_cong[OF refl sets_C[symmetric, OF \<omega>]])
next
  case (Suc l) with \<omega> show ?case
    by (simp add: bind_assoc[symmetric, OF _ measurable_eP]) (simp add: ac_simps)
qed

lemma nn_integral_C:
  assumes "m \<le> m'" and f[measurable]: "f \<in> borel_measurable (PiM {0..<n+m} M)"
    and nonneg: "\<And>x. x \<in> space (PiM {0..<n+m} M) \<Longrightarrow> 0 \<le> f x"
    and x: "x \<in> space (PiM {0..<n} M)"
  shows "(\<integral>\<^sup>+x. f x \<partial>C n m x) = (\<integral>\<^sup>+x. f (restrict x {0..<n+m}) \<partial>C n m' x)"
  using \<open>m \<le> m'\<close>
proof (induction rule: dec_induct)
  case (step i)
  let ?E = "\<lambda>x. f (restrict x {0..<n + m})" and ?C = "\<lambda>i f. \<integral>\<^sup>+x. f x \<partial>C n i x"
  from \<open>m\<le>i\<close> x have "?C i ?E = ?C (Suc i) ?E"
    by (auto simp: nn_integral_bind[where B="PiM {0 ..< Suc (n + i)} M"] space_C nn_integral_eP
             intro!: nn_integral_cong)
       (simp add: space_PiM PiE_iff  nonneg prob_space.emeasure_space_1[OF prob_space_P])
  with step show ?case by (simp del: restrict_apply)
qed (auto simp: space_PiM space_C[OF x] simp del: restrict_apply intro!: nn_integral_cong)

lemma emeasure_C:
  assumes "m \<le> m'" and A[measurable]: "A \<in> sets (PiM {0..<n+m} M)" and [simp]: "x \<in> space (PiM {0..<n} M)"
  shows "emeasure (C n m' x) (prod_emb {0..<n + m'} M {0..<n+m} A) = emeasure (C n m x) A"
  using assms
  by (subst (1 2) nn_integral_indicator[symmetric])
     (auto intro!: nn_integral_cong split: split_indicator simp del: nn_integral_indicator
           simp: nn_integral_C[of m m' _ n] prod_emb_iff space_PiM PiE_iff sets_C space_C)

lemma distr_C:
  assumes "m \<le> m'" and [simp]: "x \<in> space (PiM {0..<n} M)"
  shows "C n m x = distr (C n m' x) (PiM {0..<n+m} M) (\<lambda>x. restrict x {0..<n+m})"
proof (rule measure_eqI)
  fix A assume "A \<in> sets (C n m x)"
  with \<open>m \<le> m'\<close> show "emeasure (C n m x) A = emeasure (distr (C n m' x) (Pi\<^sub>M {0..<n + m} M) (\<lambda>x. restrict x {0..<n + m})) A"
    by (subst emeasure_C[symmetric, OF \<open>m \<le> m'\<close>]) (auto intro!: emeasure_distr_restrict[symmetric] simp: sets_C)
qed (simp add: sets_C)

definition up_to :: "nat set \<Rightarrow> nat" where
  "up_to J = (LEAST n. \<forall>i\<ge>n. i \<notin> J)"

lemma up_to_less: "finite J \<Longrightarrow> i \<in> J \<Longrightarrow> i < up_to J"
  unfolding up_to_def
  by (rule LeastI2[of _ "Suc (Max J)"]) (auto simp: Suc_le_eq not_le[symmetric])

lemma up_to_iff: "finite J \<Longrightarrow> up_to J \<le> n \<longleftrightarrow> (\<forall>i\<in>J. i < n)"
proof safe
  show "finite J \<Longrightarrow> up_to J \<le> n \<Longrightarrow> i \<in> J \<Longrightarrow> i < n" for i
    using up_to_less[of J i] by auto
qed (auto simp: up_to_def intro!: Least_le)

lemma up_to_iff_Ico: "finite J \<Longrightarrow> up_to J \<le> n \<longleftrightarrow> J \<subseteq> {0..<n}"
  by (auto simp: up_to_iff)

lemma up_to: "finite J \<Longrightarrow> J \<subseteq> {0..< up_to J}"
  by (auto simp: up_to_less)

lemma up_to_mono: "J \<subseteq> H \<Longrightarrow> finite H \<Longrightarrow> up_to J \<le> up_to H"
  by (auto simp add: up_to_iff finite_subset up_to_less)

definition CI :: "nat set \<Rightarrow> (nat \<Rightarrow> 'a) measure" where
  "CI J = distr (C 0 (up_to J) (\<lambda>x. undefined)) (PiM J M) (\<lambda>f. restrict f J)"

sublocale PF: projective_family UNIV CI
  unfolding projective_family_def
proof safe
  show "finite J \<Longrightarrow> prob_space (CI J)" for J
    using up_to[of J] unfolding CI_def
    by (intro prob_space.prob_space_distr prob_space_C measurable_restrict) auto
  note measurable_cong_sets[OF sets_C, simp]
  have [simp]: "J \<subseteq> H \<Longrightarrow> (\<lambda>f. restrict f J) \<in> measurable (Pi\<^sub>M H M) (Pi\<^sub>M J M)" for H J
    by (auto intro!: measurable_restrict)

  show "J \<subseteq> H \<Longrightarrow> finite H \<Longrightarrow> CI J = distr (CI H) (Pi\<^sub>M J M) (\<lambda>f. restrict f J)" for J H
    by (simp add: CI_def distr_C[OF up_to_mono[of J H]] up_to up_to_mono distr_distr comp_def
                  inf.absorb2 finite_subset)
qed

lemma emeasure_CI':
  "finite J \<Longrightarrow> X \<in> sets (PiM J M) \<Longrightarrow> CI J X = C 0 (up_to J) (\<lambda>_. undefined) (PF.emb {0..<up_to J} J X)"
  unfolding CI_def using up_to[of J] by (rule emeasure_distr_restrict) (auto simp: sets_C)

lemma emeasure_CI:
  "J \<subseteq> {0..<n} \<Longrightarrow> X \<in> sets (PiM J M) \<Longrightarrow> CI J X = C 0 n (\<lambda>_. undefined) (PF.emb {0..<n} J X)"
  apply (subst emeasure_CI', simp_all add: finite_subset)
  apply (subst emeasure_C[symmetric, of "up_to J" n])
  apply (auto simp: finite_subset up_to_iff_Ico up_to_less)
  apply (subst prod_emb_trans)
  apply (auto simp: up_to_less finite_subset up_to_iff_Ico)
  done

lemma lim:
  assumes J: "finite J" and X: "X \<in> sets (PiM J M)"
  shows "emeasure PF.lim (PF.emb UNIV J X) = emeasure (CI J) X"
proof (rule PF.emeasure_lim[OF J subset_UNIV X])
  fix J X' assume J[simp]: "\<And>i. finite (J i)" and X'[measurable]: "\<And>i. X' i \<in> sets (Pi\<^sub>M (J i) M)"
    and dec: "decseq (\<lambda>i. PF.emb UNIV (J i) (X' i))"
  define X where "X n =
    (\<Inter>i\<in>{i. J i \<subseteq> {0..< n}}. PF.emb {0..<n} (J i) (X' i)) \<inter> space (PiM {0..<n} M)" for n

  have sets_X[measurable]: "X n \<in> sets (PiM {0..<n} M)" for n
    by (cases "{i. J i \<subseteq> {0..< n}} = {}")
       (simp_all add: X_def, auto intro!: sets.countable_INT' sets.Int)

  have dec_X: "n \<le> m \<Longrightarrow> X m \<subseteq> PF.emb {0..<m} {0..<n} (X n)" for n m
    unfolding X_def using ivl_subset[of 0 n 0 m]
    by (cases "{i. J i \<subseteq> {0..< n}} = {}")
       (auto simp add: prod_emb_Int prod_emb_PiE space_PiM simp del: ivl_subset)

  have dec_X': "PF.emb {0..<n} (J j) (X' j) \<subseteq> PF.emb {0..<n} (J i) (X' i)"
    if [simp]: "J i \<subseteq> {0..<n}" "J j \<subseteq> {0..<n}" "i \<le> j" for n i j
    by (rule PF.emb_preserve_mono[of "{0..<n}" UNIV]) (auto del: subsetI intro: dec[THEN antimonoD])

  assume "0 < (INF i. CI (J i) (X' i))"
  also have "\<dots> \<le> (INF i. C 0 i (\<lambda>x. undefined) (X i))"
  proof (intro INF_greatest)
    fix n
    interpret C: prob_space "C 0 n (\<lambda>x. undefined)"
      by (rule prob_space_C) simp
    show "(INF i. CI (J i) (X' i)) \<le> C 0 n (\<lambda>x. undefined) (X n)"
    proof cases
      assume "{i. J i \<subseteq> {0..< n}} = {}" with C.emeasure_space_1  show ?thesis
        by (auto simp add: X_def space_C intro!: INF_lower2[of 0] prob_space.measure_le_1 PF.prob_space_P)
    next
      assume *: "{i. J i \<subseteq> {0..< n}} \<noteq> {}"
      have "(INF i. CI (J i) (X' i)) \<le>
          (INF i\<in>{i. J i \<subseteq> {0..<n}}. C 0 n (\<lambda>_. undefined) (PF.emb {0..<n} (J i) (X' i)))"
        by (intro INF_superset_mono) (auto simp: emeasure_CI)
      also have "\<dots> = C 0 n (\<lambda>_. undefined) (\<Inter>i\<in>{i. J i \<subseteq> {0..<n}}. (PF.emb {0..<n} (J i) (X' i)))"
        using * by (intro emeasure_INT_decseq_subset[symmetric]) (auto intro!: dec_X' del: subsetI simp: sets_C)
      also have "\<dots> = C 0 n (\<lambda>_. undefined) (X n)"
        using * by (auto simp add: X_def INT_extend_simps)
      finally show "(INF i. CI (J i) (X' i)) \<le> C 0 n (\<lambda>_. undefined) (X n)" .
    qed
  qed
  finally have pos: "0 < (INF i. C 0 i (\<lambda>x. undefined) (X i))" .
  from less_INF_D[OF this, of 0] have "X 0 \<noteq> {}"
    by auto

  { fix \<omega> n assume \<omega>: "\<omega> \<in> space (PiM {0..<n} M)"
    let ?C = "\<lambda>i. emeasure (C n i \<omega>) (X (n + i))"
    let ?C' = "\<lambda>i x. emeasure (C (Suc n) i (\<omega>(n:=x))) (X (Suc n + i))"
    have M: "\<And>i. ?C' i \<in> borel_measurable (P n \<omega>)"
      using \<omega>[measurable, simp] measurable_fun_upd[where J="{0..<n}"] by measurable auto

    assume "0 < (INF i. ?C i)"
    also have "\<dots> \<le> (INF i. emeasure (C n (1 + i) \<omega>) (X (n + (1 + i))))"
      by (intro INF_greatest INF_lower) auto
    also have "\<dots> = (INF i. \<integral>\<^sup>+x. ?C' i x \<partial>P n \<omega>)"
      using \<omega> measurable_C[of "Suc n"]
      apply (intro INF_cong refl)
      apply (subst split_C[symmetric, OF \<omega>])
      apply (subst emeasure_bind[OF _ _ sets_X])
      apply (simp_all del: C.simps add: space_C)
      apply measurable
      apply simp
      apply (simp add: bind_return[OF measurable_eP] nn_integral_eP)
      done
    also have "\<dots> = (\<integral>\<^sup>+x. (INF i. ?C' i x) \<partial>P n \<omega>)"
    proof (rule nn_integral_monotone_convergence_INF_AE[symmetric])
      have "(\<integral>\<^sup>+x. ?C' 0 x \<partial>P n \<omega>) \<le> (\<integral>\<^sup>+x. 1 \<partial>P n \<omega>)"
        by (intro nn_integral_mono) (auto split: split_indicator)
      also have "\<dots> < \<infinity>"
        using prob_space_P[OF \<omega>, THEN prob_space.emeasure_space_1] by simp
      finally show "(\<integral>\<^sup>+x. ?C' 0 x \<partial>P n \<omega>) < \<infinity>" .
    next
      show "AE x in P n \<omega>. ?C' (Suc i) x \<le> ?C' i x" for i
      proof (rule AE_I2)
        fix x assume "x \<in> space (P n \<omega>)"
        with \<omega> have \<omega>': "\<omega>(n := x) \<in> space (PiM {0..<Suc n} M)"
          by (auto simp: space_P[OF \<omega>] space_PiM PiE_iff extensional_def)
        with \<omega> show "?C' (Suc i) x \<le> ?C' i x"
          apply (subst emeasure_C[symmetric, of i "Suc i"])
          apply (auto intro!: emeasure_mono[OF dec_X] del: subsetI
                      simp: sets_C space_P)
          apply (subst sets_bind[OF sets_eP])
          apply (simp_all add: space_C space_P)
          done
      qed
    qed fact
    finally have "(\<integral>\<^sup>+x. (INF i. ?C' i x) \<partial>P n \<omega>) \<noteq> 0"
      by simp
    with M have "\<exists>\<^sub>F x in ae_filter (P n \<omega>). 0 < (INF i. ?C' i x)"
       by (subst (asm) nn_integral_0_iff_AE)
          (auto intro!: borel_measurable_INF simp: Filter.not_eventually not_le zero_less_iff_neq_zero)
    then have "\<exists>\<^sub>F x in ae_filter (P n \<omega>). x \<in> space (M n) \<and> 0 < (INF i. ?C' i x)"
      by (rule frequently_mp[rotated]) (auto simp: space_P \<omega>)
    then obtain x where "x \<in> space (M n)" "0 < (INF i. ?C' i x)"
      by (auto dest: frequently_ex)
    from this(2)[THEN less_INF_D, of 0] this(2)
    have "\<exists>x. \<omega>(n := x) \<in> X (Suc n) \<and> 0 < (INF i. ?C' i x)"
      by (intro exI[of _ x]) (simp split: split_indicator_asm) }
  note step = this

  let ?\<omega> = "\<lambda>\<omega> n x. (restrict \<omega> {0..<n})(n := x)"
  let ?L = "\<lambda>\<omega> n r. INF i. emeasure (C (Suc n) i (?\<omega> \<omega> n r)) (X (Suc n + i))"
  have *: "(\<And>i. i < n \<Longrightarrow> ?\<omega> \<omega> i (\<omega> i) \<in> X (Suc i)) \<Longrightarrow>
    restrict \<omega> {0..<n} \<in> space (Pi\<^sub>M {0..<n} M)" for \<omega> n
    using sets.sets_into_space[OF sets_X, of n]
    by (cases n) (auto simp: atLeastLessThanSuc restrict_def[of _ "{}"])
  have "\<exists>\<omega>. \<forall>n. ?\<omega> \<omega> n (\<omega> n) \<in> X (Suc n) \<and> 0 < ?L \<omega> n (\<omega> n)"
  proof (rule dependent_wellorder_choice)
    fix n \<omega> assume IH: "\<And>i. i < n \<Longrightarrow> ?\<omega> \<omega> i (\<omega> i) \<in> X (Suc i) \<and> 0 < ?L \<omega> i (\<omega> i)"
    show "\<exists>r. ?\<omega> \<omega> n r \<in> X (Suc n) \<and> 0 < ?L \<omega> n r"
    proof (rule step)
      show "restrict \<omega> {0..<n} \<in> space (Pi\<^sub>M {0..<n} M)"
        using IH[THEN conjunct1] by (rule *)
      show "0 < (INF i. emeasure (C n i (restrict \<omega> {0..<n})) (X (n + i)))"
      proof (cases n)
        case 0 with pos show ?thesis
          by (simp add: CI_def restrict_def)
      next
        case (Suc i) then show ?thesis
          using IH[of i, THEN conjunct2] by (simp add: atLeastLessThanSuc)
      qed
    qed
  qed (simp cong: restrict_cong)
  then obtain \<omega> where \<omega>: "\<And>n. ?\<omega> \<omega> n (\<omega> n) \<in> X (Suc n)"
    by auto
  from this[THEN *] have \<omega>_space: "\<omega> \<in> space (PiM UNIV M)"
    by (auto simp: space_PiM PiE_iff Ball_def)
  have *: "\<omega> \<in> PF.emb UNIV {0..<n} (X n)" for n
  proof (cases n)
    case 0 with \<omega>_space \<open>X 0 \<noteq> {}\<close> sets.sets_into_space[OF sets_X, of 0] show ?thesis
      by (auto simp add: space_PiM prod_emb_def restrict_def PiE_iff)
  next
    case (Suc i) then show ?thesis
      using \<omega>[of i] \<omega>_space by (auto simp: prod_emb_def space_PiM PiE_iff atLeastLessThanSuc)
  qed
  have **: "{i. J i \<subseteq> {0..<up_to (J n)}} \<noteq> {}" for n
    by (auto intro!: exI[of _ n] up_to J)
  have "\<omega> \<in> PF.emb UNIV (J n) (X' n)" for n
    using *[of "up_to (J n)"] up_to[of "J n"] by (simp add: X_def prod_emb_Int prod_emb_INT[OF **])
  then show "(\<Inter>i. PF.emb UNIV (J i) (X' i)) \<noteq> {}"
    by auto
qed

lemma distr_lim: assumes J[simp]: "finite J" shows "distr PF.lim (PiM J M) (\<lambda>x. restrict x J) = CI J"
  apply (rule measure_eqI)
  apply (simp add: CI_def)
  apply (simp add: emeasure_distr measurable_cong_sets[OF PF.sets_lim] lim[symmetric] prod_emb_def space_PiM)
  done

end

lemma (in product_prob_space) emeasure_lim_emb:
  assumes *: "finite J" "J \<subseteq> I" "X \<in> sets (PiM J M)"
  shows "emeasure lim (emb I J X) = emeasure (Pi\<^sub>M J M) X"
proof (rule emeasure_lim[OF *], goal_cases)
  case (1 J X)

  have "\<exists>Q. (\<forall>i. sets Q = PiM (\<Union>i. J i) M \<and> distr Q (PiM (J i) M) (\<lambda>x. restrict x (J i)) = Pi\<^sub>M (J i) M)"
  proof cases
    assume "finite (\<Union>i. J i)"
    then have "distr (PiM (\<Union>i. J i) M) (Pi\<^sub>M (J i) M) (\<lambda>x. restrict x (J i)) = Pi\<^sub>M (J i) M" for i
      by (intro distr_restrict[symmetric]) auto
    then show ?thesis
      by auto
  next
    assume inf: "infinite (\<Union>i. J i)"
    moreover have count: "countable (\<Union>i. J i)"
      using 1(3) by (auto intro: countable_finite)
    define f where "f = from_nat_into (\<Union>i. J i)"
    define t where "t = to_nat_on (\<Union>i. J i)"
    have ft[simp]: "x \<in> J i \<Longrightarrow> f (t x) = x" for x i
      unfolding f_def t_def using inf count by (intro from_nat_into_to_nat_on) auto
    have tf[simp]: "t (f i) = i" for i
      unfolding t_def f_def by (intro to_nat_on_from_nat_into_infinite inf count)
    have inj_t: "inj_on t (\<Union>i. J i)"
      using count by (auto simp: t_def)
    then have inj_t_J: "inj_on t (J i)" for i
      by (rule subset_inj_on) auto
    interpret IT: Ionescu_Tulcea "\<lambda>i \<omega>. M (f i)" "\<lambda>i. M (f i)"
      by standard auto
    interpret Mf: product_prob_space "\<lambda>x. M (f x)" UNIV
      by standard
    have C_eq_PiM: "IT.C 0 n (\<lambda>_. undefined) = PiM {0..<n} (\<lambda>x. M (f x))" for n
    proof (induction n)
      case 0 then show ?case
        by (auto simp: PiM_empty intro!: measure_eqI dest!: subset_singletonD)
    next
      case (Suc n) then show ?case
        apply (auto intro!: measure_eqI simp: sets_bind[OF IT.sets_eP] emeasure_bind[OF _ IT.measurable_eP])
        apply (auto simp: Mf.product_nn_integral_insert nn_integral_indicator[symmetric] atLeastLessThanSuc IT.emeasure_eP space_PiM
                    split: split_indicator simp del: nn_integral_indicator intro!: nn_integral_cong)
        done
    qed
    have CI_eq_PiM: "IT.CI X = PiM X (\<lambda>x. M (f x))" if X: "finite X" for X
      by (auto simp: IT.up_to_less X  IT.CI_def C_eq_PiM intro!: Mf.distr_restrict[symmetric])

    let ?Q = "distr IT.PF.lim (PiM (\<Union>i. J i) M) (\<lambda>\<omega>. \<lambda>x\<in>\<Union>i. J i. \<omega> (t x))"
    { fix i
      have "distr ?Q (Pi\<^sub>M (J i) M) (\<lambda>x. restrict x (J i)) =
        distr IT.PF.lim (Pi\<^sub>M (J i) M) ((\<lambda>\<omega>. \<lambda>n\<in>J i. \<omega> (t n)) \<circ> (\<lambda>\<omega>. restrict \<omega> (t`J i)))"
      proof (subst distr_distr)
        have "(\<lambda>\<omega>. \<omega> (t x)) \<in> measurable (Pi\<^sub>M UNIV (\<lambda>x. M (f x))) (M x)" if x: "x \<in> J i" for x i
          using measurable_component_singleton[of "t x" "UNIV" "\<lambda>x. M (f x)"] unfolding ft[OF x] by simp
        then show "(\<lambda>\<omega>. \<lambda>x\<in>\<Union>i. J i. \<omega> (t x)) \<in> measurable IT.PF.lim (Pi\<^sub>M (\<Union>(J ` UNIV)) M)"
          by (auto intro!: measurable_restrict simp: measurable_cong_sets[OF IT.PF.sets_lim refl])
      qed (auto intro!: distr_cong measurable_restrict measurable_component_singleton)
      also have "\<dots> = distr (distr IT.PF.lim (PiM (t`J i) (\<lambda>x. M (f x))) (\<lambda>\<omega>. restrict \<omega> (t`J i))) (Pi\<^sub>M (J i) M) (\<lambda>\<omega>. \<lambda>n\<in>J i. \<omega> (t n))"
      proof (intro distr_distr[symmetric])
        have "(\<lambda>\<omega>. \<omega> (t x)) \<in> measurable (Pi\<^sub>M (t`J i) (\<lambda>x. M (f x))) (M x)" if x: "x \<in> J i" for x
          using measurable_component_singleton[of "t x" "t`J i" "\<lambda>x. M (f x)"] x unfolding ft[OF x] by auto
        then show "(\<lambda>\<omega>. \<lambda>n\<in>J i. \<omega> (t n)) \<in> measurable (Pi\<^sub>M (t ` J i) (\<lambda>x. M (f x))) (Pi\<^sub>M (J i) M)"
          by (auto intro!: measurable_restrict)
      qed (auto intro!: measurable_restrict simp: measurable_cong_sets[OF IT.PF.sets_lim refl])
      also have "\<dots> = distr (PiM (t`J i) (\<lambda>x. M (f x))) (Pi\<^sub>M (J i) M) (\<lambda>\<omega>. \<lambda>n\<in>J i. \<omega> (t n))"
        using \<open>finite (J i)\<close> by (subst IT.distr_lim) (auto simp: CI_eq_PiM)
      also have "\<dots> = Pi\<^sub>M (J i) M"
        using Mf.distr_reorder[of t "J i"] by (simp add: 1 inj_t_J cong: PiM_cong)
      finally have "distr ?Q (Pi\<^sub>M (J i) M) (\<lambda>x. restrict x (J i)) = Pi\<^sub>M (J i) M" . }
    then show "\<exists>Q. \<forall>i. sets Q = PiM (\<Union>i. J i) M \<and> distr Q (Pi\<^sub>M (J i) M) (\<lambda>x. restrict x (J i)) = Pi\<^sub>M (J i) M"
      by (intro exI[of _ ?Q]) auto
  qed
  then obtain Q where sets_Q: "sets Q = PiM (\<Union>i. J i) M"
    and Q: "\<And>i. distr Q (PiM (J i) M) (\<lambda>x. restrict x (J i)) = Pi\<^sub>M (J i) M" by blast

  from 1 interpret Q: prob_space Q
    by (intro prob_space_distrD[of "\<lambda>x. restrict x (J 0)" Q "PiM (J 0) M"])
       (auto simp: Q measurable_cong_sets[OF sets_Q]
                intro!: prob_space_P measurable_restrict measurable_component_singleton)

  have "0 < (INF i. emeasure (Pi\<^sub>M (J i) M) (X i))" by fact
  also have "\<dots> = (INF i. emeasure Q (emb (\<Union>i. J i) (J i) (X i)))"
    by (simp add: emeasure_distr_restrict[OF _ sets_Q 1(4), symmetric] SUP_upper Q)
  also have "\<dots> = emeasure Q (\<Inter>i. emb (\<Union>i. J i) (J i) (X i))"
  proof (rule INF_emeasure_decseq)
    from 1 show "decseq (\<lambda>n. emb (\<Union>i. J i) (J n) (X n))"
      by (intro antimonoI emb_preserve_mono[where X="emb (\<Union>i. J i) (J n) (X n)" and L=I and J="\<Union>i. J i" for n]
         measurable_prod_emb)
         (auto simp: SUP_least SUP_upper antimono_def)
  qed (insert 1, auto simp: sets_Q)
  finally have "(\<Inter>i. emb (\<Union>i. J i) (J i) (X i)) \<noteq> {}"
    by auto
  moreover have "(\<Inter>i. emb I (J i) (X i)) = {} \<Longrightarrow> (\<Inter>i. emb (\<Union>i. J i) (J i) (X i)) = {}"
    using 1 by (intro emb_injective[of "\<Union>i. J i" I _ "{}"] sets.countable_INT) (auto simp: SUP_least SUP_upper)
  ultimately show ?case by auto
qed

end


chapter \<open>Sine and Cosine Upper and Lower Bounds\<close>

theory Sin_Cos_Bounds
imports Bounds_Lemmas

begin

section\<open>Simple base cases\<close>

text\<open>Upper bound for @{term"x\<ge>0"}\<close>
lemma sin_le_arg:
  fixes x :: real
    shows "0 \<le> x \<Longrightarrow> sin x \<le> x"
  by (fact sin_x_le_x)

lemma cos_ge_1_arg:
  fixes x :: real
  assumes "0 \<le> x"
    shows "1 - x \<le> cos x"
  apply (rule gen_lower_bound_increasing [OF assms])
  apply (intro derivative_eq_intros, auto)
  done

lemmas sin_Taylor_0_upper_bound_pos = sin_le_arg \<comment> \<open>MetiTarski bound\<close>

lemma cos_Taylor_1_lower_bound:
  fixes x :: real
  assumes "0 \<le> x"
    shows "(1 - x^2 / 2) \<le> cos x"
  apply (rule gen_lower_bound_increasing [OF assms])
  apply (intro derivative_eq_intros)
  apply (rule refl | simp add: sin_le_arg)+
  done

lemma sin_Taylor_1_lower_bound:
  fixes x :: real
  assumes "0 \<le> x"
    shows "(x - x ^ 3 / 6) \<le> sin x"
  apply (rule gen_lower_bound_increasing [OF assms])
  apply (intro derivative_eq_intros)
  apply (rule refl | simp add: cos_Taylor_1_lower_bound)+
  done

section\<open>Taylor series approximants\<close>

definition sinpoly :: "[nat,real] \<Rightarrow> real"
  where "sinpoly n = (\<lambda>x. \<Sum>k<n. sin_coeff k * x ^ k)"

definition cospoly :: "[nat,real] \<Rightarrow> real"
  where "cospoly n = (\<lambda>x. \<Sum>k<n. cos_coeff k * x ^ k)"

(*sin upper bounds have the form 4*n+2; lower bounds, 4*n
sinpoly 2 x = x                                      (upper)
sinpoly 4 x = x - (x^3)/6                            (lower)
sinpoly 6 x = x - (x^3)/6 + (x^5)/120                (upper)
sinpoly 8 x = x - (x^3)/6 + (x^5)/120 - (x^7)/5040   (lower)

cos upper bounds have the form 4*n+1; lower bounds, 4*n+3
cospoly 1 x = 1                                                             (upper)
cospoly 3 x = 1 - (x^2)/2                                                   (lower)
cospoly 5 x = 1 - (x^2)/2 + (x^4)/24 - x^6/720 + x^8/40320                  (upper)
cospoly 7 x = 1 - (x^2)/2 + (x^4)/24 - x^6/720 + x^8/40320 - x^10/3628800   (lower)
*)

lemma cospoly_Suc: "cospoly (Suc n) = (\<lambda>x. cospoly n x + cos_coeff n * x ^ n)"
  by (simp add: cospoly_def)

lemma sinpoly_minus [simp]: "sinpoly n (-x) = - sinpoly n x"
  by (induct n) (auto simp: sinpoly_def sin_coeff_def)

lemma cospoly_minus [simp]: "cospoly n (-x) = cospoly n x"
  by (induct n) (auto simp: cospoly_def cos_coeff_def)

lemma d_sinpoly_cospoly:
    "(sinpoly (Suc n) has_field_derivative cospoly n x) (at x)"
proof (induction n)
  case 0 show ?case
    by (simp add: sinpoly_def cospoly_def)
next
  case (Suc n) show ?case
  proof (cases "n=0")
    case True then show ?thesis
      by (simp add: sinpoly_def sin_coeff_def cospoly_def)
  next
    case False then
    have xn: "x ^ (n - Suc 0) * x = x ^ n"
      by (metis Suc_pred mult.commute not_gr0 power_Suc)
    show ?thesis using Suc False
      apply (simp add: sinpoly_Suc [of "Suc n"] cospoly_def)
      apply (intro derivative_eq_intros | simp)+
      apply (simp add: xn mult.assoc sin_coeff_def cos_coeff_def divide_simps del: fact_Suc)
      apply (simp add: algebra_simps)
      done
  qed
qed

lemma d_cospoly_sinpoly:
    "(cospoly (Suc n) has_field_derivative -sinpoly n x) (at x)"
proof (induction n)
  case 0 show ?case
    by (simp add: sinpoly_def cospoly_def)
next
  case (Suc n) show ?case
  proof (cases "n=0")
    case True then show ?thesis
      by (simp add: sinpoly_def cospoly_def cos_coeff_def)
  next
    case False then
    have xn: "x ^ (n - Suc 0) * x = x ^ n"
      by (metis Suc_pred mult.commute not_gr0 power_Suc)
    have m1: "odd n \<Longrightarrow> (-1 :: real) ^ ((n - Suc 0) div 2) = - ((-1) ^ (Suc n div 2))"
      by (cases n) simp_all
    show ?thesis using Suc False
      apply (simp add: cospoly_Suc [of "Suc n"] sinpoly_def)
      apply (intro derivative_eq_intros | simp)+
      apply (simp add: xn mult.assoc sin_coeff_def cos_coeff_def m1 divide_simps del: fact_Suc)
      apply (simp add: algebra_simps)
      done
  qed
qed

section\<open>Inductive proof of sine inequalities\<close>

lemma sinpoly_lb_imp_cospoly_ub:
  assumes x0: "0 \<le> x" and k0: "k>0" and "\<And>x. 0 \<le> x \<Longrightarrow> sinpoly (k - 1) x \<le> sin x"
    shows "cos x \<le> cospoly k x"
  apply (rule gen_lower_bound_increasing [OF x0])
  apply (intro derivative_eq_intros | simp)+
  using d_cospoly_sinpoly [of "k - 1"] assms
  apply auto
  apply (simp add: cospoly_def)
  done

lemma cospoly_ub_imp_sinpoly_ub:
  assumes x0: "0 \<le> x" and k0: "k>0" and "\<And>x. 0 \<le> x \<Longrightarrow> cos x \<le> cospoly (k - 1) x"
    shows "sin x \<le> sinpoly k x"
  apply (rule gen_lower_bound_increasing [OF x0])
  apply (intro derivative_eq_intros | simp)+
  using d_sinpoly_cospoly [of "k - 1"] assms
  apply auto
  apply (simp add: sinpoly_def)
  done

lemma sinpoly_ub_imp_cospoly_lb:
  assumes x0: "0 \<le> x" and k0: "k>0" and "\<And>x. 0 \<le> x \<Longrightarrow> sin x \<le> sinpoly (k - 1) x"
    shows "cospoly k x \<le> cos x"
  apply (rule gen_lower_bound_increasing [OF x0])
  apply (intro derivative_eq_intros | simp)+
  using d_cospoly_sinpoly [of "k - 1"] assms
  apply auto
  apply (simp add: cospoly_def)
  done

lemma cospoly_lb_imp_sinpoly_lb:
  assumes x0: "0 \<le> x" and k0: "k>0" and "\<And>x. 0 \<le> x \<Longrightarrow> cospoly (k - 1) x \<le> cos x"
    shows "sinpoly k x \<le> sin x"
  apply (rule gen_lower_bound_increasing [OF x0])
  apply (intro derivative_eq_intros | simp)+
  using d_sinpoly_cospoly [of "k - 1"] assms
  apply auto
  apply (simp add: sinpoly_def)
  done

lemma
  assumes "0 \<le> x"
    shows sinpoly_lower_nonneg: "sinpoly (4 * Suc n) x \<le> sin x"        (is ?th1)
      and sinpoly_upper_nonneg: "sin x \<le> sinpoly (Suc (Suc (4*n))) x"  (is ?th2)
proof -
  have "sinpoly (4 * Suc n) x \<le> sin x  \<and>  sin x \<le> sinpoly (Suc (Suc (4*n))) x"
    using assms
    apply (induction n arbitrary: x)
    apply (simp add: sinpoly_def sin_coeff_def sin_Taylor_1_lower_bound sin_Taylor_0_upper_bound_pos lessThan_nat_numeral fact_numeral)
    apply (auto simp: cospoly_lb_imp_sinpoly_lb sinpoly_ub_imp_cospoly_lb cospoly_ub_imp_sinpoly_ub sinpoly_lb_imp_cospoly_ub)
    done
  then show ?th1 ?th2
    using assms
    by auto
qed

section\<open>Collecting the results\<close>

corollary sinpoly_upper_nonpos:
     "x \<le> 0 \<Longrightarrow> sin x \<le> sinpoly (4 * Suc n) x"
  using sinpoly_lower_nonneg [of "-x" n]
  by simp

corollary sinpoly_lower_nonpos:
     "x \<le> 0 \<Longrightarrow> sinpoly (Suc (Suc (4*n))) x \<le> sin x"
  using sinpoly_upper_nonneg [of "-x" n]
  by simp

corollary cospoly_lower_nonneg:
     "0 \<le> x \<Longrightarrow> cospoly (Suc (Suc (Suc (4*n)))) x \<le> cos x"
by (auto simp: sinpoly_upper_nonneg sinpoly_ub_imp_cospoly_lb)

lemma cospoly_lower:
     "cospoly (Suc (Suc (Suc (4*n)))) x \<le> cos x"
proof (cases rule: le_cases [of 0 x])
  case le then show ?thesis
    by (simp add: cospoly_lower_nonneg)
next
  case ge then show ?thesis using cospoly_lower_nonneg [of "-x"]
    by simp
qed

lemma cospoly_upper_nonneg:
  assumes "0 \<le> x"
    shows "cos x \<le> cospoly (Suc (4*n)) x"
proof (cases n)
  case 0 then show ?thesis
    by (simp add: cospoly_def)
next
  case (Suc m)
  then show ?thesis
    using sinpoly_lower_nonneg [of _ m] assms
    by (auto simp: sinpoly_lb_imp_cospoly_ub)
qed

lemma cospoly_upper:
  "cos x \<le> cospoly (Suc (4*n)) x"
proof (cases rule: le_cases [of 0 x])
  case le then show ?thesis
    by (simp add: cospoly_upper_nonneg)
next
  case ge then show ?thesis using cospoly_upper_nonneg [of "-x"]
    by simp
qed

end


(*  Title:      HOL/Library/Code_Binary_Nat.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Implementation of natural numbers as binary numerals\<close>

theory Code_Binary_Nat
imports Code_Abstract_Nat
begin

text \<open>
  When generating code for functions on natural numbers, the
  canonical representation using \<^term>\<open>0::nat\<close> and
  \<^term>\<open>Suc\<close> is unsuitable for computations involving large
  numbers.  This theory refines the representation of
  natural numbers for code generation to use binary
  numerals, which do not grow linear in size but logarithmic.
\<close>

subsection \<open>Representation\<close>

code_datatype "0::nat" nat_of_num

lemma [code]:
  "(1::nat) = Numeral1"
  by simp

lemma [code_abbrev]: "Numeral1 = (1::nat)"
  by simp

lemma [code]:
  "Suc n = n + 1"
  by simp

subsection \<open>Basic arithmetic\<close>

context
begin

declare [[code drop: "plus :: nat \<Rightarrow> _"]]

lemma plus_nat_code [code]:
  "nat_of_num k + nat_of_num l = nat_of_num (k + l)"
  "m + 0 = (m::nat)"
  "0 + n = (n::nat)"
  by (simp_all add: nat_of_num_numeral)

text \<open>Bounded subtraction needs some auxiliary\<close>

qualified definition dup :: "nat \<Rightarrow> nat" where
  "dup n = n + n"

lemma dup_code [code]:
  "dup 0 = 0"
  "dup (nat_of_num k) = nat_of_num (Num.Bit0 k)"
  by (simp_all add: dup_def numeral_Bit0)

qualified definition sub :: "num \<Rightarrow> num \<Rightarrow> nat option" where
  "sub k l = (if k \<ge> l then Some (numeral k - numeral l) else None)"

lemma sub_code [code]:
  "sub Num.One Num.One = Some 0"
  "sub (Num.Bit0 m) Num.One = Some (nat_of_num (Num.BitM m))"
  "sub (Num.Bit1 m) Num.One = Some (nat_of_num (Num.Bit0 m))"
  "sub Num.One (Num.Bit0 n) = None"
  "sub Num.One (Num.Bit1 n) = None"
  "sub (Num.Bit0 m) (Num.Bit0 n) = map_option dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit1 n) = map_option dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit0 n) = map_option (\<lambda>q. dup q + 1) (sub m n)"
  "sub (Num.Bit0 m) (Num.Bit1 n) = (case sub m n of None \<Rightarrow> None
     | Some q \<Rightarrow> if q = 0 then None else Some (dup q - 1))"
  apply (auto simp add: nat_of_num_numeral
    Num.dbl_def Num.dbl_inc_def Num.dbl_dec_def
    Let_def le_imp_diff_is_add BitM_plus_one sub_def dup_def)
  apply (simp_all add: sub_non_positive)
  apply (simp_all add: sub_non_negative [symmetric, where ?'a = int])
  done

declare [[code drop: "minus :: nat \<Rightarrow> _"]]

lemma minus_nat_code [code]:
  "nat_of_num k - nat_of_num l = (case sub k l of None \<Rightarrow> 0 | Some j \<Rightarrow> j)"
  "m - 0 = (m::nat)"
  "0 - n = (0::nat)"
  by (simp_all add: nat_of_num_numeral sub_non_positive sub_def)

declare [[code drop: "times :: nat \<Rightarrow> _"]]

lemma times_nat_code [code]:
  "nat_of_num k * nat_of_num l = nat_of_num (k * l)"
  "m * 0 = (0::nat)"
  "0 * n = (0::nat)"
  by (simp_all add: nat_of_num_numeral)

declare [[code drop: "HOL.equal :: nat \<Rightarrow> _"]]

lemma equal_nat_code [code]:
  "HOL.equal 0 (0::nat) \<longleftrightarrow> True"
  "HOL.equal 0 (nat_of_num l) \<longleftrightarrow> False"
  "HOL.equal (nat_of_num k) 0 \<longleftrightarrow> False"
  "HOL.equal (nat_of_num k) (nat_of_num l) \<longleftrightarrow> HOL.equal k l"
  by (simp_all add: nat_of_num_numeral equal)

lemma equal_nat_refl [code nbe]:
  "HOL.equal (n::nat) n \<longleftrightarrow> True"
  by (rule equal_refl)

declare [[code drop: "less_eq :: nat \<Rightarrow> _"]]

lemma less_eq_nat_code [code]:
  "0 \<le> (n::nat) \<longleftrightarrow> True"
  "nat_of_num k \<le> 0 \<longleftrightarrow> False"
  "nat_of_num k \<le> nat_of_num l \<longleftrightarrow> k \<le> l"
  by (simp_all add: nat_of_num_numeral)

declare [[code drop: "less :: nat \<Rightarrow> _"]]

lemma less_nat_code [code]:
  "(m::nat) < 0 \<longleftrightarrow> False"
  "0 < nat_of_num l \<longleftrightarrow> True"
  "nat_of_num k < nat_of_num l \<longleftrightarrow> k < l"
  by (simp_all add: nat_of_num_numeral)

declare [[code drop: Euclidean_Rings.divmod_nat]]

lemma divmod_nat_code [code]:
  "Euclidean_Rings.divmod_nat (nat_of_num k) (nat_of_num l) = divmod k l"
  "Euclidean_Rings.divmod_nat m 0 = (0, m)"
  "Euclidean_Rings.divmod_nat 0 n = (0, 0)"
  by (simp_all add: Euclidean_Rings.divmod_nat_def nat_of_num_numeral)

end

subsection \<open>Conversions\<close>

declare [[code drop: of_nat]]

lemma of_nat_code [code]:
  "of_nat 0 = 0"
  "of_nat (nat_of_num k) = numeral k"
  by (simp_all add: nat_of_num_numeral)

code_identifier
  code_module Code_Binary_Nat \<rightharpoonup>
    (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


(*  Title:      HOL/Proofs/Extraction/Pigeonhole.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>The pigeonhole principle\<close>

theory Pigeonhole
imports Util "HOL-Library.Realizers" "HOL-Library.Code_Target_Numeral"
begin

text \<open>
  We formalize two proofs of the pigeonhole principle, which lead
  to extracted programs of quite different complexity. The original
  formalization of these proofs in {\sc Nuprl} is due to
  Aleksey Nogin @{cite "Nogin-ENTCS-2000"}.

  This proof yields a polynomial program.
\<close>

theorem pigeonhole:
  "\<And>f. (\<And>i. i \<le> Suc n \<Longrightarrow> f i \<le> n) \<Longrightarrow> \<exists>i j. i \<le> Suc n \<and> j < i \<and> f i = f j"
proof (induct n)
  case 0
  then have "Suc 0 \<le> Suc 0 \<and> 0 < Suc 0 \<and> f (Suc 0) = f 0" by simp
  then show ?case by iprover
next
  case (Suc n)
  have r:
    "k \<le> Suc (Suc n) \<Longrightarrow>
    (\<And>i j. Suc k \<le> i \<Longrightarrow> i \<le> Suc (Suc n) \<Longrightarrow> j < i \<Longrightarrow> f i \<noteq> f j) \<Longrightarrow>
    (\<exists>i j. i \<le> k \<and> j < i \<and> f i = f j)" for k
  proof (induct k)
    case 0
    let ?f = "\<lambda>i. if f i = Suc n then f (Suc (Suc n)) else f i"
    have "\<not> (\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j)"
    proof
      assume "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j"
      then obtain i j where i: "i \<le> Suc n" and j: "j < i" and f: "?f i = ?f j"
        by iprover
      from j have i_nz: "Suc 0 \<le> i" by simp
      from i have iSSn: "i \<le> Suc (Suc n)" by simp
      have S0SSn: "Suc 0 \<le> Suc (Suc n)" by simp
      show False
      proof cases
        assume fi: "f i = Suc n"
        show False
        proof cases
          assume fj: "f j = Suc n"
          from i_nz and iSSn and j have "f i \<noteq> f j" by (rule 0)
          moreover from fi have "f i = f j"
            by (simp add: fj [symmetric])
          ultimately show ?thesis ..
        next
          from i and j have "j < Suc (Suc n)" by simp
          with S0SSn and le_refl have "f (Suc (Suc n)) \<noteq> f j"
            by (rule 0)
          moreover assume "f j \<noteq> Suc n"
          with fi and f have "f (Suc (Suc n)) = f j" by simp
          ultimately show False ..
        qed
      next
        assume fi: "f i \<noteq> Suc n"
        show False
        proof cases
          from i have "i < Suc (Suc n)" by simp
          with S0SSn and le_refl have "f (Suc (Suc n)) \<noteq> f i"
            by (rule 0)
          moreover assume "f j = Suc n"
          with fi and f have "f (Suc (Suc n)) = f i" by simp
          ultimately show False ..
        next
          from i_nz and iSSn and j
          have "f i \<noteq> f j" by (rule 0)
          moreover assume "f j \<noteq> Suc n"
          with fi and f have "f i = f j" by simp
          ultimately show False ..
        qed
      qed
    qed
    moreover have "?f i \<le> n" if "i \<le> Suc n" for i
    proof -
      from that have i: "i < Suc (Suc n)" by simp
      have "f (Suc (Suc n)) \<noteq> f i"
        by (rule 0) (simp_all add: i)
      moreover have "f (Suc (Suc n)) \<le> Suc n"
        by (rule Suc) simp
      moreover from i have "i \<le> Suc (Suc n)" by simp
      then have "f i \<le> Suc n" by (rule Suc)
      ultimately show ?thesis
        by simp
    qed
    then have "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j"
      by (rule Suc)
    ultimately show ?case ..
  next
    case (Suc k)
    from search [OF nat_eq_dec] show ?case
    proof
      assume "\<exists>j<Suc k. f (Suc k) = f j"
      then show ?case by (iprover intro: le_refl)
    next
      assume nex: "\<not> (\<exists>j<Suc k. f (Suc k) = f j)"
      have "\<exists>i j. i \<le> k \<and> j < i \<and> f i = f j"
      proof (rule Suc)
        from Suc show "k \<le> Suc (Suc n)" by simp
        fix i j assume k: "Suc k \<le> i" and i: "i \<le> Suc (Suc n)"
          and j: "j < i"
        show "f i \<noteq> f j"
        proof cases
          assume eq: "i = Suc k"
          show ?thesis
          proof
            assume "f i = f j"
            then have "f (Suc k) = f j" by (simp add: eq)
            with nex and j and eq show False by iprover
          qed
        next
          assume "i \<noteq> Suc k"
          with k have "Suc (Suc k) \<le> i" by simp
          then show ?thesis using i and j by (rule Suc)
        qed
      qed
      then show ?thesis by (iprover intro: le_SucI)
    qed
  qed
  show ?case by (rule r) simp_all
qed

text \<open>
  The following proof, although quite elegant from a mathematical point of view,
  leads to an exponential program:
\<close>

theorem pigeonhole_slow:
  "\<And>f. (\<And>i. i \<le> Suc n \<Longrightarrow> f i \<le> n) \<Longrightarrow> \<exists>i j. i \<le> Suc n \<and> j < i \<and> f i = f j"
proof (induct n)
  case 0
  have "Suc 0 \<le> Suc 0" ..
  moreover have "0 < Suc 0" ..
  moreover from 0 have "f (Suc 0) = f 0" by simp
  ultimately show ?case by iprover
next
  case (Suc n)
  from search [OF nat_eq_dec] show ?case
  proof
    assume "\<exists>j < Suc (Suc n). f (Suc (Suc n)) = f j"
    then show ?case by (iprover intro: le_refl)
  next
    assume "\<not> (\<exists>j < Suc (Suc n). f (Suc (Suc n)) = f j)"
    then have nex: "\<forall>j < Suc (Suc n). f (Suc (Suc n)) \<noteq> f j" by iprover
    let ?f = "\<lambda>i. if f i = Suc n then f (Suc (Suc n)) else f i"
    have "\<And>i. i \<le> Suc n \<Longrightarrow> ?f i \<le> n"
    proof -
      fix i assume i: "i \<le> Suc n"
      show "?thesis i"
      proof (cases "f i = Suc n")
        case True
        from i and nex have "f (Suc (Suc n)) \<noteq> f i" by simp
        with True have "f (Suc (Suc n)) \<noteq> Suc n" by simp
        moreover from Suc have "f (Suc (Suc n)) \<le> Suc n" by simp
        ultimately have "f (Suc (Suc n)) \<le> n" by simp
        with True show ?thesis by simp
      next
        case False
        from Suc and i have "f i \<le> Suc n" by simp
        with False show ?thesis by simp
      qed
    qed
    then have "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j" by (rule Suc)
    then obtain i j where i: "i \<le> Suc n" and ji: "j < i" and f: "?f i = ?f j"
      by iprover
    have "f i = f j"
    proof (cases "f i = Suc n")
      case True
      show ?thesis
      proof (cases "f j = Suc n")
        assume "f j = Suc n"
        with True show ?thesis by simp
      next
        assume "f j \<noteq> Suc n"
        moreover from i ji nex have "f (Suc (Suc n)) \<noteq> f j" by simp
        ultimately show ?thesis using True f by simp
      qed
    next
      case False
      show ?thesis
      proof (cases "f j = Suc n")
        assume "f j = Suc n"
        moreover from i nex have "f (Suc (Suc n)) \<noteq> f i" by simp
        ultimately show ?thesis using False f by simp
      next
        assume "f j \<noteq> Suc n"
        with False f show ?thesis by simp
      qed
    qed
    moreover from i have "i \<le> Suc (Suc n)" by simp
    ultimately show ?thesis using ji by iprover
  qed
qed

extract pigeonhole pigeonhole_slow

text \<open>
  The programs extracted from the above proofs look as follows:
  @{thm [display] pigeonhole_def}
  @{thm [display] pigeonhole_slow_def}
  The program for searching for an element in an array is
  @{thm [display,eta_contract=false] search_def}
  The correctness statement for \<^term>\<open>pigeonhole\<close> is
  @{thm [display] pigeonhole_correctness [no_vars]}

  In order to analyze the speed of the above programs,
  we generate ML code from them.
\<close>

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation prod :: (default, default) default
begin

definition "default = (default, default)"

instance ..

end

definition "test n u = pigeonhole (nat_of_integer n) (\<lambda>m. m - 1)"
definition "test' n u = pigeonhole_slow (nat_of_integer n) (\<lambda>m. m - 1)"
definition "test'' u = pigeonhole 8 (List.nth [0, 1, 2, 3, 4, 5, 6, 3, 7, 8])"

ML_val "timeit (@{code test} 10)"
ML_val "timeit (@{code test'} 10)"
ML_val "timeit (@{code test} 20)"
ML_val "timeit (@{code test'} 20)"
ML_val "timeit (@{code test} 25)"
ML_val "timeit (@{code test'} 25)"
ML_val "timeit (@{code test} 500)"
ML_val "timeit @{code test''}"

end