section \<open>The Laurent series expansion of $\zeta$ at 1\<close>
theory Zeta_Laurent_Expansion
  imports Zeta_Function
begin

text \<open>
  In this section, we shall derive the Laurent series expansion of $\zeta(s)$ at $s = 1$, which
  is of the form
    \[\zeta(s) = \frac{1}{s-1} + \sum_{n=0}^\infty \frac{(-1)^n\,\gamma_n}{n!} (s-1)^n\]
  where the $\gamma_n$ are the \<^emph>\<open>Stieltjes constants\<close>. Notably, $\gamma_0$ is equal to
  the Euler--Mascheroni constant $\gamma$.
\<close>

subsection \<open>Definition of the Stieltjes constants\<close>

text \<open>
  We define the Stieltjes constants by their infinite series form, since it is fairly
  easy to show the convergence of the series by the comparison test.
\<close>
definition%important stieltjes_gamma :: "nat \<Rightarrow> 'a :: real_algebra_1" where
  "stieltjes_gamma n =
     of_real (\<Sum>k. ln (k+1) ^ n / (k+1) - (ln (k+2) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1))"

lemma stieltjes_gamma_0 [simp]: "stieltjes_gamma 0 = euler_mascheroni"
  using euler_mascheroni_sum_real by (simp add: sums_iff stieltjes_gamma_def field_simps)

lemma stieltjes_gamma_summable:
  "summable (\<lambda>k. ln (k+1) ^ n / (k+1) - (ln (k+2) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1))"
    (is "summable ?f")
proof (rule summable_comparison_test_bigo)
  (* TODO: good real_asymp example *)
  (* TODO: investigate how to make this more automatic *)
  have "eventually (\<lambda>x::real. ln x ^ n - ln x ^ (n+1) * (inverse (ln x) * (1 + real n)) *
           inverse (real n + 1) = 0) at_top"
    using eventually_gt_at_top[of 1] by eventually_elim (auto simp: field_simps)
  thus "?f \<in> O(\<lambda>k. k powr (-3/2))"
    by real_asymp
qed (simp_all add: summable_real_powr_iff)

lemma of_real_stieltjes_gamma [simp]: "of_real (stieltjes_gamma k) = stieltjes_gamma k"
  by (simp add: stieltjes_gamma_def)

text \<open>
  We can now derive the alternative definition of the Stieltjes constants as a limit.
  This limit can also be written in the Euler--MacLaurin-style form
  \[\lim\limits_{m\to\infty} \left(\sum\limits_{k=1}^m \frac{\ln^n k}{k} -
       \int_1^m \frac{\ln^n x}{x}\,\text{d}x\right)\,,\]
  which is perhaps a bit more illuminating.
\<close>
lemma stieltjes_gamma_real_limit_form:
  "(\<lambda>m. (\<Sum>k = 1..m. ln (real k) ^ n / real k) - ln (real m) ^ (n + 1) / real (n + 1))
     \<longlonglongrightarrow> stieltjes_gamma n"
proof -
  have "(\<lambda>m::nat. \<Sum>k<m.  ln (k+1) ^ n / (k+1) - (ln (k+2) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1))
          \<longlonglongrightarrow> stieltjes_gamma n"
    using sums_stieltjes_gamma[of n] by (simp add: add_ac sums_def)
  also have "(\<lambda>m::nat. \<Sum>k<m.  ln (k+1) ^ n / (k+1) - (ln (k+2) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1)) =
        (\<lambda>m::nat. (\<Sum>k=1..m. ln k ^ n / k) - ln (m + 1) ^ (n + 1) / (n + 1))"
    (is "?lhs = ?rhs")
  proof (rule ext, goal_cases)
    fix m :: nat
    have "(\<Sum>k<m. ln (k+1) ^ n / (k+1) - (ln (k+2) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1)) =
            (\<Sum>k<m. ln (k+1) ^ n / (k+1)) -
            (\<Sum>k<m. ln (Suc k+1) ^ (n+1) - ln (k+1) ^ (n + 1)) / (n + 1)"
      by (simp add: sum_subtractf flip: sum_divide_distrib)
    also have "(\<Sum>k<m. ln (k+1) ^ n / (k+1)) = (\<Sum>k=1..m. ln k ^ n / k)"
      by (rule sum.reindex_bij_witness[of _ "\<lambda>k. k-1" Suc]) auto
    also have "(\<Sum>k<m. ln (Suc k+1) ^ (n+1) - ln (k+1) ^ (n + 1)) = ln (m + 1) ^ (n + 1)"
      by (subst sum_lessThan_telescope) simp_all
    finally show "?lhs m = ?rhs m" .
  qed
  finally have *: "(\<lambda>m. (\<Sum>k = 1..m. ln k ^ n / k) - ln (m + 1) ^ (n + 1) / (n + 1))
                     \<longlonglongrightarrow> stieltjes_gamma n" .
  have **: "(\<lambda>m. ln (m + 1) ^ (n + 1) / (n + 1) - ln m ^ (n + 1) / (n + 1)) \<longlonglongrightarrow> 0"
    by real_asymp
  from tendsto_add[OF * **] show ?thesis by (simp add: algebra_simps)
qed

lemma stieltjes_gamma_limit_form:
  "(\<lambda>m. of_real ((\<Sum>k=1..m. ln (real k) ^ n / real k) - ln (real m) ^ (n + 1) / real (n + 1)))
     \<longlonglongrightarrow> (stieltjes_gamma n :: 'a :: real_normed_algebra_1)"
proof -
  have "(\<lambda>m.  of_real ((\<Sum>k=1..m. ln (real k) ^ n / real k) - ln m ^ (n + 1) / real (n + 1)))
          \<longlonglongrightarrow> (of_real (stieltjes_gamma n) :: 'a)"
    using stieltjes_gamma_real_limit_form[of n] by (intro tendsto_of_real) (auto simp: add_ac)
  thus ?thesis by simp
qed

lemma stieltjes_gamma_real_altdef:
  "(stieltjes_gamma n :: real) =
     lim (\<lambda>m. (\<Sum>k = 1..m. ln (real k) ^ n / real k) -
              ln (real m) ^ (n + 1) / real (n + 1))"
  by (rule sym, rule limI, rule stieltjes_gamma_real_limit_form)

subsection \<open>Proof of the Laurent expansion\<close>

text \<open>
  We shall follow the proof by Briggs and Chowla~\cite{briggs55}, which examines the entire
  function $g(s) = (2^{1-s}-1)\zeta(s)$. They determine the value of $g^{(k)}(1)$ in two
  different ways: First by the Dirichlet series of $g$ and then by its power series expansion
  around 1. We shall do the same here.
\<close>

context
  fixes g and G1 G2 G2' G :: "complex fps" and A :: "nat \<Rightarrow> complex"
  defines "g \<equiv> perzeta (1 / 2)"
  defines "G1 \<equiv> fps_shift 1 (fps_exp (-ln 2 :: complex) - 1)"
  defines "G2 \<equiv> fps_expansion (\<lambda>s. (s - 1) * pre_zeta 1 s + 1) 1"
  defines "G2' \<equiv> fps_expansion (pre_zeta 1) 1"
  defines "G \<equiv> G1 * G2"
  defines "A \<equiv> fps_nth G2"
begin

text \<open>
  @{term "G1"}, @{term "G2"}, @{term "G2'"}, and @{term "G2"} are the formal power series
  expansions of functions around \<open>s = 1\<close> of the entire functions

    \<^item> $(2^{1-s} - 1) / (s - 1)$,

    \<^item> $(s - 1) \zeta(s)$,

    \<^item> $\zeta(s) - \frac{1}{s-1}$,

    \<^item> $(2^{1-s}-1) \zeta(s)$,

  respectively.

  Our goal is to determine the coefficients of @{term G2'}, and we shall do so
  by determining the coefficients of @{term G2} (which are the same, but shifted by 1).
  This in turn will be done by determining the coefficients of @{term "G = G1 * G2"}.

  Note that $(2^{1-s} - 1) \zeta(s)$ is written as @{term "perzeta (1/2)"} in Isabelle
  (using the periodic \<open>\<zeta>\<close> function) and the analytic continuation of $\zeta(s) - \frac{1}{s-1}$
  is written as @{term "pre_zeta 1 s"} (@{const pre_zeta} is an artefact from the definition of
  @{const zeta}, which comes in useful here).
\<close>

lemma stieltjes_gamma_aux1: "(\<lambda>n. (-1)^(n+1) * ln(n+1)^k / (n+1)) sums ((-1)^k * (deriv^^k) g 1)"
proof -
  define H where "H = fds_perzeta (1 / 2)"
  have conv: "conv_abscissa H < 1" unfolding H_def
    by (rule le_less_trans[OF conv_abscissa_perzeta']) (use fraction_not_in_ints[of 2 1] in auto)
  have [simp]: "eval_fds H s = g s" if "Re s > 0" for s
    unfolding H_def g_def using fraction_not_in_ints[of 2 1] that
    by (subst perzeta_altdef2) auto
  have ev: "eventually (\<lambda>s. s \<in> {s. Re s > 0}) (nhds 1)"
    by (intro eventually_nhds_in_open open_halfspace_Re_gt) auto
  have [simp]: "(deriv ^^ k) (eval_fds H) 1 = (deriv ^^ k) g 1"
    by (intro higher_deriv_cong_ev eventually_mono[OF ev]) auto

  have "fds_converges ((fds_deriv ^^ k) H) 1"
    by (intro fds_converges le_less_trans[OF conv_abscissa_higher_deriv_le])
       (use conv in \<open>simp add: one_ereal_def\<close>)
  hence "(\<lambda>n. fds_nth ((fds_deriv ^^ k) H) (n+1) / real (n+1)) sums eval_fds ((fds_deriv ^^ k) H) 1"
    by (simp add: fds_converges_altdef)
  also have "eval_fds ((fds_deriv ^^ k) H) 1 = (deriv ^^ k) (eval_fds H) 1"
    using conv by (intro eval_fds_higher_deriv) (auto simp: one_ereal_def)
  also have "(\<lambda>n. fds_nth ((fds_deriv ^^ k) H) (n+1) / real (n+1)) =
               (\<lambda>n. (-1)^k * (-1)^(n+1) * ln (real (n+1)) ^ k / (n+1))"
    by (auto simp: fds_nth_higher_deriv algebra_simps H_def fds_perzeta_one_half Ln_Reals_eq)
  finally have "(\<lambda>n. (- 1) ^ k * complex_of_real ((-1)^(n+1) * ln (real (n+1)) ^ k / real (n+1))) sums
                   ((deriv ^^ k) g 1)" by (simp add: algebra_simps)

  hence "(\<lambda>n. (-1)^k * ((-1)^k * complex_of_real ((-1)^(n+1) * ln (real (n+1)) ^ k / real (n+1)))) sums
                     ((-1)^k * (deriv ^^ k) g 1)" by (intro sums_mult)
  also have "(\<lambda>n. (-1)^k * ((-1)^k * complex_of_real ((-1)^(n+1) * ln (real (n+1)) ^ k / real (n+1)))) =
             (\<lambda>n. complex_of_real ((-1)^(n+1) * ln (real (n+1)) ^ k / real (n+1)))"
    by (intro ext) auto
  finally show ?thesis .
qed

lemma stieltjes_gamma_aux2: "(deriv^^k) g 1 = fact k * fps_nth G k"
  and stieltjes_gamma_aux3: "G2 = fps_X * G2' + 1"
proof -
  have [simp]: "fps_conv_radius G1 = \<infinity>"
    using fps_conv_radius_diff[of "fps_exp (-Ln 2)" 1] by (simp add: G1_def)
  have "fps_conv_radius G2 \<ge> \<infinity>"
    unfolding G2_def by (intro conv_radius_fps_expansion holomorphic_intros) auto
  hence [simp]: "fps_conv_radius G2 = \<infinity>"
    by simp
  have "fps_conv_radius G2' \<ge> \<infinity>"
    unfolding G2'_def by (intro conv_radius_fps_expansion holomorphic_intros) auto
  hence [simp]: "fps_conv_radius G2' = \<infinity>"
    by simp
  have [simp]: "fps_conv_radius G = \<infinity>"
    using fps_conv_radius_mult[of G1 G2] by (simp add: G_def)

  have eval_G1: "eval_fps G1 (s - 1) =
                   (if s = 1 then -ln 2 else (2 powr (1 - s) - 1) / (s - 1))" for s
      unfolding G1_def using fps_conv_radius_diff[of "fps_exp (-Ln 2)" 1]
      by (subst eval_fps_shift)
         (auto intro!: subdegree_geI simp: eval_fps_diff powr_def exp_diff exp_minus algebra_simps)
  have eval_G2: "eval_fps G2 (s - 1) = (s - 1) * pre_zeta 1 s + 1" for s
    unfolding G2_def by (subst eval_fps_expansion[where r = \<infinity>]) (auto intro!: holomorphic_intros)
  have eval_G: "eval_fps G (s - 1) = g s" for s
    unfolding G_def by (simp add: eval_fps_mult eval_G1 eval_G2 g_def perzeta_one_half_left')
  have eval_G': "eval_fps G s = g (1 + s)" for s
    using eval_G[of "s + 1"] by (simp add: add_ac)
  have eval_G2': "eval_fps G2' (s - 1) = pre_zeta 1 s" for s
    unfolding G2'_def by (intro eval_fps_expansion[where r = \<infinity>]) (auto intro!: holomorphic_intros)

  show "G2 = fps_X * G2' + 1"
  proof (intro eval_fps_eqD always_eventually allI)
    have *: "fps_conv_radius (fps_X * G2') = \<infinity>"
      using fps_conv_radius_mult[of fps_X G2'] by simp
    from * show "fps_conv_radius (fps_X * G2' + 1) > 0"
      using fps_conv_radius_add[of "fps_X * G2'" 1] by auto
    show "eval_fps G2 s = eval_fps (fps_X * G2' + 1) s" for s
      using * eval_G2[of "1 + s"] eval_G2'[of "1 + s"]
      by (simp add: eval_fps_add eval_fps_mult)
  qed auto

  have "G = fps_expansion g 1"
  proof (rule eval_fps_eqD)
    have "fps_conv_radius (fps_expansion g 1) \<ge> \<infinity>"
      using fraction_not_in_ints[of 2 1]
      by (intro conv_radius_fps_expansion) (auto intro!: holomorphic_intros simp: g_def)
    thus "fps_conv_radius (fps_expansion g 1) > 0" by simp
  next
    have "eval_fps (fps_expansion g 1) z = g (1 + z)" for z
      using fraction_not_in_ints[of 2 1]
      by (subst eval_fps_expansion'[where r = \<infinity>]) (auto simp: g_def intro!: holomorphic_intros)
    thus "eventually (\<lambda>z. eval_fps G z = eval_fps (fps_expansion g 1) z) (nhds 0)"
      by (simp add: eval_G')
  qed auto
  thus "(deriv ^^ k) g 1 = fact k * fps_nth G k"
    by (simp add: fps_eq_iff fps_expansion_def)
qed

lemma stieltjes_gamma_aux4: "fps_nth G k = (\<Sum>i=1..k+1. (-ln 2)^i * A (k-(i-1)) / fact i)"
proof -
  have "fps_nth G k = (\<Sum>i\<le>k. fps_nth G1 i * A (k - i))"
    unfolding G_def fps_mult_nth A_def by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>i\<le>k. (-ln 2)^(i+1) * A (k - i) / fact (i+1))"
    by (simp add: G1_def algebra_simps)
  also have "\<dots> = (\<Sum>i=1..k+1. (-ln 2)^i * A (k-(i-1)) / fact i)"
    by (intro sum.reindex_bij_witness[of _ "\<lambda>i. i-1" Suc]) (auto simp: Suc_diff_Suc)
  finally show ?thesis .
qed

lemma stieltjes_gamma_aux5: "(\<Sum>t<k. (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t) -
             ln 2 ^ (k+1) / of_nat (k+1) = (-1) ^ k * (deriv ^^ k) g 1"
proof -
  define h where "h = (\<lambda>k x. (\<Sum>n=1..x. ln(real n)^k / real n) -
                         ln (real x)^(k+1) / real(k+1) - stieltjes_gamma k)"
  have h_eq: "(\<Sum>n=1..x. ln n ^ k / n) = ln x^(k+1) / real (k+1) + stieltjes_gamma k + h k x"
    for k x :: nat by (simp add: h_def)
  define h' where "h' = (\<lambda>x. \<Sum>t=0..k. (k choose t) * ln 2 ^ (k - t) * h t x)"
  define S1 where "S1 = (\<lambda>x. (\<Sum>t=0..k. (k choose t) * ln 2 ^ (k - t) * ln x ^ (t + 1) / (t + 1)))"
  define S2 where "S2 = (\<lambda>x. (\<Sum>t=0..k. (k choose t) * ln 2 ^ (k - t) * ln x ^ (t + 1) / (k + 1)))"

  have [THEN filterlim_compose, tendsto_intros]: "h t \<longlonglongrightarrow> 0" for t
    using tendsto_diff[OF stieltjes_gamma_real_limit_form[of t] tendsto_const[of "stieltjes_gamma t"]]
    by (simp add: h_def)

  have eq: "(\<Sum>n=1..2 * x. (-1)^(n+1) * ln n ^ k / n) =
              ln 2 ^ (k+1) / real (k+1) -
              (\<Sum>t<k. (k choose t) * ln 2 ^ (k-t) * stieltjes_gamma t) + h k (2*x) - h' x"
    (is "?lhs x = ?rhs x") if "x > 0" for x :: nat
  proof -
    have "2 * (\<Sum>n=1..x. ln (2*n)^k/(2*n)) =
           (\<Sum>n=1..x. \<Sum>t=0..k. 1/n * (k choose t) * ln 2 ^ (k-t) * ln n ^ t)"
      unfolding sum_distrib_left
    proof (rule sum.cong)
      fix n :: nat assume n: "n \<in> {1..x}"
      have "2 * (ln (2*n)^k / (2*n)) = 1/n * (ln n + ln 2) ^ k"
        using n by (simp add: ln_mult add_ac)
      also have "(ln n + ln 2) ^ k = (\<Sum>t=0..k. (k choose t) * ln 2 ^ (k-t) * ln n ^ t)"
        by (subst binomial_ring, rule sum.cong) auto
      also have "1/n * \<dots> = (\<Sum>t=0..k. 1/n * (k choose t) * ln 2 ^ (k-t) * ln n ^ t)"
        by (subst sum_distrib_left) (simp add: mult_ac)
      finally show "2 * (ln (2*n)^k / (2*n)) = \<dots>" .
    qed auto
    also have "\<dots> = (\<Sum>t=0..k. \<Sum>n=1..x. 1/n * (k choose t) * ln 2 ^ (k-t) * ln n ^ t)"
      by (rule sum.swap)
    also have "\<dots> = (\<Sum>t=0..k. (k choose t) * ln 2 ^ (k - t) *
                      (ln x ^ (t+1) / (t+1) + stieltjes_gamma t + h t x))"
    proof (rule sum.cong)
      fix t :: nat assume t: "t \<in> {0..k}"
      have "(\<Sum>n=1..x. 1/n * (k choose t) * ln 2 ^ (k-t) * ln n ^ t) =
            (k choose t) * ln 2 ^ (k - t) * (\<Sum>n=1..x. ln n ^ t / n)"
        by (subst sum_distrib_left) (simp add: mult_ac)
      also have "(\<Sum>n=1..x. ln n ^ t / n) = ln x ^ (t+1) / (t+1) + stieltjes_gamma t + h t x"
        using h_eq[of t] by simp
      finally show "(\<Sum>n=1..x. 1/n * (k choose t) * ln 2 ^ (k-t) * ln n ^ t) =
                      (k choose t) * ln 2 ^ (k - t) * \<dots>" .
    qed simp_all
    also have "\<dots> = (\<Sum>t=0..k. (k choose t) / (t + 1) * ln 2 ^ (k - t) * ln x ^ (t + 1)) +
                    (\<Sum>t=0..k. (k choose t) * ln 2 ^ (k - t) * stieltjes_gamma t) + h' x"
      by (simp add: ring_distribs sum.distrib h'_def)
    also have "(\<Sum>t=0..k. (k choose t) / (t + 1) * ln 2 ^ (k - t) * ln x ^ (t + 1)) =
               (\<Sum>t=0..k. (Suc k choose Suc t) / (k + 1) * ln 2 ^ (k - t) * ln x ^ (t + 1))"
    proof (intro sum.cong refl, goal_cases)
      case (1 t)
      have "of_nat (k choose t) * (of_nat (k + 1) :: real) = of_nat ((k choose t) * (k + 1))"
        by (simp only: of_nat_mult)
      also have "(k choose t) * (k + 1) = (Suc k choose Suc t) * (t + 1)"
        using Suc_times_binomial_eq[of k t] by (simp add: algebra_simps)
      also have "of_nat \<dots> = of_nat (Suc k choose Suc t) * (of_nat (t + 1) :: real)"
        by (simp only: of_nat_mult)
      finally have *: "of_nat (k choose t) / of_nat (t + 1) =
                         (of_nat (Suc k choose Suc t) / (k + 1) :: real)"
        by (simp add: divide_simps flip: of_nat_Suc del: binomial_Suc_Suc)
      show ?case by (simp only: *)
    qed
    also have "\<dots> = (\<Sum>t=1..Suc k. (Suc k choose t) / (k + 1) * ln 2 ^ (Suc k - t) * ln x ^ t)"
      by (intro sum.reindex_bij_witness[of _ "\<lambda>t. t-1" Suc]) auto
    also have "{1..Suc k} = {..Suc k} - {0}" by auto
    also have "(\<Sum>t\<in>\<dots>. (Suc k choose t) / (k + 1) * ln 2 ^ (Suc k - t) * ln x ^ t) =
                 (\<Sum>t\<le>Suc k. (Suc k choose t) / (k + 1) * ln 2 ^ (Suc k - t) * ln x ^ t) -
                   ln 2 ^ Suc k / (k + 1)"
      by (subst sum_diff1) auto
    also have "(\<Sum>t\<le>Suc k. (Suc k choose t) / (k + 1) * ln 2 ^ (Suc k - t) * ln x ^ t) =
               (ln x + ln 2) ^ Suc k / (k + 1)"
      unfolding binomial_ring by (subst sum_divide_distrib) (auto simp: algebra_simps)
    also have "ln x + ln 2 = ln (2 * x)"
      using \<open>x > 0\<close> by (simp add: ln_mult)
    finally have eq1: "2 * (\<Sum>n=1..x. ln (real (2*n))^k / real (2*n)) =
                         ln (real (2*x))^(k+1) / real (k+1) - ln 2^(k+1) / real (k+1) +
                         (\<Sum>t=0..k. (k choose t) * ln 2^(k - t) * stieltjes_gamma t) + h' x"
      by (simp add: algebra_simps)

    have eq2: "(\<Sum>n=1..2*x. ln n ^ k / n) = ln (real (2*x))^(k+1) / real (k+1) + stieltjes_gamma k + h k (2*x)"
      by (simp only: h_eq)

    have "(\<Sum>n=1..2*x. (-1)^(n+1) * ln n ^ k / n) =
          (\<Sum>n=1..2*x. ln n ^ k / n - 2 * (if even n then ln n ^ k / n else 0))"
      by (intro sum.cong) auto
    also have "\<dots> = (\<Sum>n=1..2*x. ln n ^ k / n) -
                    2 * (\<Sum>n=1..2*x. if even n then ln n ^ k / n else 0)"
      by (simp only: sum_subtractf sum_distrib_left)
    also have "(\<Sum>n=1..2*x. if even n then ln n ^ k / n else 0) =
               (\<Sum>n | n \<in> {1..2*x} \<and> even n. ln n ^ k / n)"
      by (intro sum.mono_neutral_cong_right) auto
    also have "\<dots> = (\<Sum>n=1..x. ln (real (2*n)) ^ k / real (2*n))"
      by (intro sum.reindex_bij_witness[of _ "\<lambda>n. 2*n" "\<lambda>n. n div 2"]) auto
    also have "(\<Sum>n=1..2*x. ln n ^ k / n) - 2 * \<dots> =
                 ln 2^(k+1) / real (k+1) -
                ((\<Sum>t=0..k. (k choose t) * ln 2^(k - t) * stieltjes_gamma t) - stieltjes_gamma k) +
                h k (2*x) - h' x"
      using arg_cong2[OF eq1 eq2, of "(-)"] by simp
    also have "{0..k} = insert k {..<k}" by auto
    also have "(\<Sum>t\<in>\<dots>. (k choose t) * ln 2^(k - t) * stieltjes_gamma t) - stieltjes_gamma k =
                 (\<Sum>t<k. (k choose t) * ln 2^(k - t) * stieltjes_gamma t)"
      by (subst sum.insert) auto
    finally show ?thesis .
  qed

  have "?rhs \<longlonglongrightarrow> ln 2 ^ (k+1) / real (k+1) -
                            (\<Sum>t<k. (k choose t) * ln 2 ^ (k-t) * stieltjes_gamma t)"
    unfolding h'_def by (rule tendsto_eq_intros refl mult_nat_left_at_top filterlim_ident | simp)+
  moreover have "eventually (\<lambda>x. ?rhs x = ?lhs x) sequentially"
    using eventually_gt_at_top[of 0] by eventually_elim (simp only: eq)
  ultimately have *: "?lhs \<longlonglongrightarrow> ln 2 ^ (k+1) / real (k+1) -
                                   (\<Sum>t<k. (k choose t) * ln 2 ^ (k-t) * stieltjes_gamma t)"
    by (rule Lim_transform_eventually)
  also have "(\<lambda>x. \<Sum>n=1..2*x. (-1)^(n+1) * ln (real n)^k / real n) =
             (\<lambda>x. \<Sum>n<2*x. -((-1)^(n+1) * ln (real (n+1))^k / real (n+1)))"
    by (intro ext sum.reindex_bij_witness[of _ Suc "\<lambda>n. n - 1"]) (auto simp: power_diff)
  also have "\<dots> = (\<lambda>x. -(\<Sum>n<2*x. ((-1)^(n+1) * ln (real (n+1))^k / real (n+1))))"
    by (subst sum_negf) auto
  finally have *: "\<dots> \<longlonglongrightarrow> (ln 2 ^ (k+1) / real (k+1) -
                              (\<Sum>t<k. (k choose t) * ln 2 ^ (k - t) * stieltjes_gamma t))" .
  have lim1: "(\<lambda>x. (\<Sum>n<2*x. complex_of_real ((-1)^(n+1) * ln (real (n+1))^k / real (n+1))))
              \<longlonglongrightarrow> -(ln 2 ^ (k+1) / of_nat (k+1) -
                      (\<Sum>t<k. (k choose t) * ln 2 ^ (k - t) * stieltjes_gamma t))"
    (is "?lhs' \<longlonglongrightarrow> _")
    using tendsto_of_real[OF tendsto_minus[OF *], where ?'a = complex]
    by (simp add: Ln_Reals_eq)

  moreover have "?lhs' \<longlonglongrightarrow> ((- 1) ^ k * (deriv ^^ k) g 1)"
  proof -
    have **: "filterlim (\<lambda>n::nat. 2 * n) sequentially sequentially" by real_asymp
    have "(\<lambda>x. (\<Sum>n<2*x. complex_of_real ((-1)^(n+1) * ln (real (n+1))^k / real (n+1))))
              \<longlonglongrightarrow> ((- 1) ^ k * (deriv ^^ k) g 1)"
      by (rule filterlim_compose[OF _ **]) (use stieltjes_gamma_aux1 in \<open>simp add: sums_def\<close>)
    thus ?thesis .
  qed

  ultimately have "-(ln 2 ^ (k+1) / of_nat (k+1) -
                      (\<Sum>t<k. (k choose t) * ln 2 ^ (k - t) * stieltjes_gamma t)) =
                   (-1) ^ k * (deriv ^^ k) g 1"
    by (rule LIMSEQ_unique)
  thus ?thesis by (simp add: Ln_Reals_eq)
qed

lemma stieltjes_gamma_aux6: "(\<Sum>t<k. (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t) -
                  Ln 2 ^ (k + 1) / of_nat (k + 1) =
                (-1)^k * fact k * (\<Sum>i=1..k+1. (-Ln 2) ^ i * A (k-(i-1)) / fact i)"
proof -
  have "(\<Sum>t<k. (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t) -
          Ln 2 ^ (k + 1) / of_nat (k + 1) = (- 1) ^ k * (deriv ^^ k) g 1"
    using stieltjes_gamma_aux5[of k] .
  also have "(deriv ^^ k) g 1 = fact k * fps_nth G k"
    by (rule stieltjes_gamma_aux2)
  also have "fps_nth G k = (\<Sum>i=1..k + 1. (-Ln 2) ^ i * A (k - (i - 1)) / fact i)"
    by (rule stieltjes_gamma_aux4)
  finally show ?thesis by (simp add: mult_ac)
qed

theorem higher_deriv_pre_zeta_1_1: "(deriv ^^ k) (pre_zeta 1) 1 = (-1) ^ k * stieltjes_gamma k"
proof -
  have eq: "A k = (if k = 0 then 1 else (-1)^(k+1) * stieltjes_gamma (k - 1) / fact (k - 1))" for k
  proof (induction k rule: less_induct)
    case (less k)
    show ?case
    proof (cases "k = 0")
      case True
      with stieltjes_gamma_aux6[of 0] show ?thesis by simp
    next
      case False
      have "k * Ln 2 * stieltjes_gamma (k - 1) +
             (\<Sum>t<k-1. (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t) =
             (\<Sum>t\<in>insert (k-1) {..<k-1}. (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t)"
        using False by (subst sum.insert) auto
      also have "insert (k-1) {..<k-1} = {..<k}" using False by auto
      also have "(\<Sum>t<k. of_nat (k choose t) * Ln 2 ^ (k - t) * stieltjes_gamma t) =
              Ln 2 ^ (k + 1) / of_nat (k + 1) +
              (- 1) ^ k * fact k * (\<Sum>i = 1..k + 1. (- Ln 2) ^ i * A (k - (i - 1)) / fact i)"
        using stieltjes_gamma_aux6[of k] by (simp add: algebra_simps)
      also have "{1..k+1} = {1,k+1} \<union> {2..k}" by auto
      also have "(- 1) ^ k * fact k * (\<Sum>i\<in>\<dots>. (- Ln 2) ^ i * A (k - (i - 1)) / fact i) =
                 (\<Sum>i=2..k. (-1)^k * fact k * (- Ln 2) ^ i * A (k - (i - 1)) / fact i)
                   -Ln 2 * A k * (- 1) ^ k * fact k +
                   (-Ln 2)^(k+1) * A 0 / fact (k+1) * (- 1) ^ k * fact k"
        using False by (subst sum.union_disjoint)
                       (auto simp: algebra_simps sum_distrib_left sum_distrib_right)
      also have "(\<Sum>i=2..k. (-1)^k * fact k * (-Ln 2) ^ i * A (k-(i-1)) / fact i) =
                 (\<Sum>i<k-1. (k choose i) * Ln 2 ^ (k-i) * stieltjes_gamma i)"
        using False
        by (intro sum.reindex_bij_witness[of _ "\<lambda>i. k - i" "\<lambda>i. k - i"])
           (auto simp: binomial_fact Suc_diff_le less field_simps power_neg_one_If)
      finally have "k * Ln 2 * stieltjes_gamma (k - 1) =
                       (-1)^(k+1) * fact k * Ln 2 * A k"
        using False by (simp add: less power_minus')
      also have "\<dots> * (-1)^(k+1) / fact k / Ln 2 = A k"
        by simp
      also have "k * Ln 2 * stieltjes_gamma (k - 1) * (-1)^(k+1) / fact k / Ln 2 =
                   (-1)^(k+1) * stieltjes_gamma (k - 1) / fact (k - 1)"
        using False by (simp add: field_simps fact_reduce)
      finally have "A k = (- 1) ^ (k + 1) * stieltjes_gamma (k - 1) / fact (k - 1)" ..
      thus ?thesis using False by simp
    qed
  qed

  have "fps_nth G2' k = fps_nth G2 (Suc k)"
    by (simp add: stieltjes_gamma_aux3)
  also have "\<dots> = A (Suc k)"
    by (simp add: A_def)
  also have "\<dots> = (-1) ^ k * stieltjes_gamma k / fact k"
    by (simp add: eq)
  finally show "(deriv ^^ k) (pre_zeta 1) 1 = (-1) ^ k * stieltjes_gamma k"
    by (simp add: G2'_def fps_eq_iff fps_expansion_def)
qed

corollary pre_zeta_1_1 [simp]: "pre_zeta 1 1 = euler_mascheroni"
  using higher_deriv_pre_zeta_1_1[of 0] by simp

corollary zeta_minus_pole_limit: "(\<lambda>s. zeta s - 1 / (s - 1)) \<midarrow>1\<rightarrow> euler_mascheroni"
proof (rule Lim_transform_eventually)
  show "eventually (\<lambda>s. pre_zeta 1 s = zeta s - 1 / (s - 1)) (at 1)"
    by (auto simp: zeta_minus_pole_eq [symmetric] eventually_at_filter)
  have "isCont (pre_zeta 1) 1"
    by (intro continuous_intros) auto
  thus "pre_zeta 1 \<midarrow>1\<rightarrow> euler_mascheroni"
    by (simp add: isCont_def)
qed

corollary fps_expansion_pre_zeta_1_1:
  "fps_expansion (pre_zeta 1) 1 = Abs_fps (\<lambda>n. (-1)^n * stieltjes_gamma n / fact n)"
  by (simp add: fps_expansion_def higher_deriv_pre_zeta_1_1)

end

end


section \<open> Down part \<close>

theory Down
imports Triangular_Function UpDown_Scheme
begin

lemma sparsegrid'_parents:
  assumes b: "b \<in> sparsegrid' dm" and p': "p' \<in> parents d b p"
  shows "p' \<in> sparsegrid' dm"
  using assms parents_def sparsegrid'I by auto

lemma down'_\<beta>: "\<lbrakk> d < length b ; l + level b = lm ; b \<in> sparsegrid' dm ; p \<in> sparsegrid' dm \<rbrakk> \<Longrightarrow>
  down' d l b fl fr \<alpha> p = (if p \<in> lgrid b {d} lm
  then
    (fl + (fr - fl) / 2 * (real_of_int (ix p d) / 2^(lv p d - lv b d) - real_of_int (ix b d) + 1)) / 2 ^ (lv p d + 1) +
    (\<Sum> p' \<in> parents d b p. (\<alpha> p') * l2_\<phi> (p ! d) (p' ! d))
  else \<alpha> p)"
proof (induct l arbitrary: b \<alpha> fl fr p)
  case (Suc l)

  let ?l = "child b left d" and ?r = "child b right d"
  let ?result = "((fl + fr) / 4 + (1 / 3) * (\<alpha> b)) / 2 ^ (lv b d)"
  let ?fm = "(fl + fr) / 2 + (\<alpha> b)"
  let ?down_l = "down' d l (child b left d) fl ?fm (\<alpha>(b := ?result))"

  have "length b = dm" using \<open>b \<in> sparsegrid' dm\<close>
    unfolding sparsegrid'_def start_def by auto
  hence "d < dm" using \<open>d < length b\<close> by auto

  have "!!dir. d < length (child b dir d)" using \<open>d < length b\<close> by auto
  have "!!dir. l + level (child b dir d) = lm"
    using \<open>d < length b\<close> and \<open>Suc l + level b = lm\<close> and child_level by auto
  have "!!dir. (child b dir d) \<in> sparsegrid' dm"
    using \<open>b \<in> sparsegrid' dm\<close> and \<open>d < dm\<close> and sparsegrid'_def by auto
  note hyps = Suc.hyps[OF \<open>!! dir. d < length (child b dir d)\<close>
    \<open>!!dir. l + level (child b dir d) = lm\<close>
    \<open>!!dir. (child b dir d) \<in> sparsegrid' dm\<close>]

  show ?case
  proof (cases "p \<in> lgrid b {d} lm")
    case False
    moreover hence "p \<noteq> b" and "p \<notin> lgrid ?l {d} lm"
       and "p \<notin> lgrid ?r {d} lm" unfolding lgrid_def
      unfolding grid_partition[where p=b] using \<open>Suc l + level b = lm\<close> by auto
    ultimately show ?thesis
      unfolding down'.simps Let_def fun_upd_def hyps[OF \<open>p \<in> sparsegrid' dm\<close>]
      by auto
  next
    case True hence "level p < lm" and "p \<in> grid b {d}" unfolding lgrid_def by auto
    let ?lb = "lv b d"   and ?ib = "real_of_int (ix b d)"
    let ?lp   = "lv p d"  and ?ip   = "real_of_int (ix p d)"
    show ?thesis
    proof (cases "\<exists> dir. p \<in> grid (child b dir d){d}")
      case True
      obtain dir where p_grid: "p \<in> grid (child b dir d) {d}" using True by auto
      hence "p \<in> lgrid (child b dir d) {d} lm" using \<open>level p < lm\<close> unfolding lgrid_def by auto
      have "lv b d < lv p d" using child_lv[OF \<open>d < length b\<close>] and grid_single_level[OF p_grid \<open>d < length (child b dir d)\<close>] by auto

      let ?ch = "child b dir d"
      let ?ich = "child b (inv dir) d"

      show ?thesis
      proof (cases dir)
        case right
        hence "p \<in> lgrid ?r {d} lm" and "p \<in> grid ?r {d}"
          using \<open>p \<in> grid ?ch {d}\<close> and \<open>level p < lm\<close> unfolding lgrid_def by auto

        { fix p' fix fl fr x assume p': "p' \<in> parents d (child b right d) p"
          hence "p' \<in> grid (child b right d) {d}" unfolding parents_def by simp
          hence "p' \<notin> lgrid (child b left d) {d} lm" and "p' \<noteq> b"
            unfolding lgrid_def
            using grid_disjunct[OF \<open>d < length b\<close>] grid_not_child by auto

          from hyps[OF sparsegrid'_parents[OF \<open>child b right d \<in> sparsegrid' dm\<close>
                       p']] this
          have "down' d l (child b left d) fl fr (\<alpha>(b := x)) p' = \<alpha> p'" by auto }
        thus  ?thesis
          unfolding down'.simps Let_def hyps[OF \<open>p \<in> sparsegrid' dm\<close>]
            parent_sum[OF \<open>p \<in> grid ?r {d}\<close> \<open>d < length b\<close>]
            l2_child[OF \<open>d < length b\<close> \<open>p \<in> grid ?r {d}\<close>]
          using child_ix child_lv \<open>d < length b\<close> level_shift[OF \<open>lv b d < lv p d\<close>]
                sgn.simps \<open>p \<in> lgrid b {d} lm\<close> \<open>p \<in> lgrid ?r {d} lm\<close>
          by (auto simp add: algebra_simps diff_divide_distrib add_divide_distrib)
      next
        case left
        hence "p \<in> lgrid ?l {d} lm" and "p \<in> grid ?l {d}"
          using \<open>p \<in> grid ?ch {d}\<close> and \<open>level p < lm\<close> unfolding lgrid_def by auto
        hence "\<not> p \<in> lgrid ?r {d} lm"
          using grid_disjunct[OF \<open>d < length b\<close>] unfolding lgrid_def by auto
        { fix p' assume p': "p' \<in> parents d (child b left d) p"
          hence "p' \<in> grid (child b left d) {d}" unfolding parents_def by simp
          hence "p' \<noteq> b" using grid_not_child[OF \<open>d < length b\<close>] by auto }
        thus ?thesis
          unfolding down'.simps Let_def hyps[OF \<open>p \<in> sparsegrid' dm\<close>]
                    parent_sum[OF \<open>p \<in> grid ?l {d}\<close> \<open>d < length b\<close>]
                    l2_child[OF \<open>d < length b\<close> \<open>p \<in> grid ?l {d}\<close>] sgn.simps
                    if_P[OF \<open>p \<in> lgrid b {d} lm\<close>] if_P[OF \<open>p \<in> lgrid ?l {d} lm\<close>]
                    if_not_P[OF \<open>p \<notin> lgrid ?r {d} lm\<close>]
          using child_ix child_lv \<open>d < length b\<close> level_shift[OF \<open>lv b d < lv p d\<close>]
          by (auto simp add: algebra_simps diff_divide_distrib add_divide_distrib)
      qed
    next
      case False hence not_child: "!! dir. \<not> p \<in> grid (child b dir d) {d}" by auto
      hence "p = b" using grid_onedim_split[where ds="{}" and d=d and b=b] \<open>p \<in> grid b {d}\<close> unfolding grid_empty_ds[where b=b] by auto
      from not_child have lnot_child: "!! dir. \<not> p \<in> lgrid (child b dir d) {d} lm" unfolding lgrid_def by auto
      have result: "((fl + fr) / 4 + 1 / 3 * \<alpha> b) / 2 ^ lv b d = (fl + (fr - fl) / 2) / 2 ^ (lv b d + 1) + \<alpha> b * l2_\<phi> (b ! d) (b ! d)"
        by (auto simp: l2_same diff_divide_distrib add_divide_distrib times_divide_eq_left[symmetric] algebra_simps)
      show ?thesis
        unfolding down'.simps Let_def fun_upd_def hyps[OF \<open>p \<in> sparsegrid' dm\<close>] if_P[OF \<open>p \<in> lgrid b {d} lm\<close>] if_not_P[OF lnot_child] if_P[OF \<open>p = b\<close>]
        unfolding \<open>p = b\<close> parents_single unfolding result by auto
    qed
  qed
next
  case 0
  have "p \<notin> lgrid b {d} lm"
  proof (rule ccontr)
    assume "\<not> p \<notin> lgrid b {d} lm"
    hence "p \<in> grid b {d}" and "level p < lm" unfolding lgrid_def by auto
    moreover from grid_level[OF \<open>p \<in> grid b {d}\<close>] and \<open>0 + level b = lm\<close> have "lm \<le> level p" by auto
    ultimately show False by auto
  qed
  thus ?case unfolding down'.simps by auto
qed

lemma down: assumes "d < dm" and p: "p \<in> sparsegrid dm lm"
  shows "(down dm lm d \<alpha>) p = (\<Sum> p' \<in> parents d (base {d} p) p. (\<alpha> p') * l2_\<phi> (p ! d) (p' ! d))"
proof -
  let "?F d l p" = "down' d l p 0 0"
  let "?S x p p'" = "if p' \<in> parents d (base {d} p) p then x * l2_\<phi> (p ! d) (p' ! d) else 0"

  { fix p \<alpha> assume "p \<in> sparsegrid dm lm"
    from le_less_trans[OF grid_level sparsegridE(2)[OF this]]
    have "parents d (base {d} p) p \<subseteq>  lgrid (base {d} p) {d} lm"
      unfolding lgrid_def parents_def by auto
    hence "(\<Sum>p'\<in>lgrid (base {d} p) {d} lm. ?S (\<alpha> p') p p') =
      (\<Sum>p'\<in>parents d (base {d} p) p. \<alpha> p' * l2_\<phi> (p ! d) (p' ! d))"
      using lgrid_finite by (intro sum.mono_neutral_cong_right) auto
  } note sum_eq = this

  { fix l p b \<alpha>
    assume b: "b \<in> lgrid (start dm) ({0..<dm} - {d}) lm" and "l + level b = lm"
      and "p \<in> sparsegrid dm lm"
    hence b_spg: "b \<in> sparsegrid' dm" and p_spg: "p \<in> sparsegrid' dm" and
      "d < length b" and "level p < lm"
      using sparsegrid'_start sparsegrid_subset \<open>d < dm\<close> by auto
    have "?F d l b \<alpha> p = (if b = base {d} p then \<Sum>p'\<in>lgrid b {d} lm. ?S (\<alpha> p') p p' else \<alpha> p)"
    proof (cases "b = base {d} p")
      case True
      have "p \<in> lgrid (base {d} p) {d} lm"
        using baseE(2)[OF p_spg] and \<open>level p < lm\<close>
        unfolding lgrid_def by auto
      thus ?thesis unfolding if_P[OF True]
        unfolding True sum_eq[OF \<open>p \<in> sparsegrid dm lm\<close>]
        unfolding down'_\<beta>[OF \<open>d < length b\<close> \<open>l + level b = lm\<close> b_spg p_spg,
          unfolded True] by auto
    next
      case False
      have "p \<notin> lgrid b {d} lm"
      proof (rule ccontr)
        assume "\<not> ?thesis" hence "p \<in> grid b {d}" by auto
        from b this have "b = base {d} p" using baseI by auto
        thus False using False by simp
      qed
      thus ?thesis
        unfolding if_not_P[OF False]
        unfolding down'_\<beta>[OF \<open>d < length b\<close> \<open>l + level b = lm\<close> b_spg p_spg]
        by auto
    qed }
  from lift[OF \<open>d < dm\<close> \<open>p \<in> sparsegrid dm lm\<close>, where F = ?F and S = ?S, OF this]
  show ?thesis
    unfolding down_def
    unfolding sum_eq[OF p] by simp
qed

end


(*  Title:      HOL/Examples/Seq.thy
    Author:     Makarius
*)

section \<open>Finite sequences\<close>

theory Seq
  imports MainRLT
begin

datatype 'a seq = Empty | Seq 'a "'a seq"

fun conc :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> 'a seq"
where
  "conc Empty ys = ys"
| "conc (Seq x xs) ys = Seq x (conc xs ys)"

fun reverse :: "'a seq \<Rightarrow> 'a seq"
where
  "reverse Empty = Empty"
| "reverse (Seq x xs) = conc (reverse xs) (Seq x Empty)"

lemma conc_empty: "conc xs Empty = xs"
  by (induct xs) simp_all

lemma conc_assoc: "conc (conc xs ys) zs = conc xs (conc ys zs)"
  by (induct xs) simp_all

lemma reverse_conc: "reverse (conc xs ys) = conc (reverse ys) (reverse xs)"
  by (induct xs) (simp_all add: conc_empty conc_assoc)

lemma reverse_reverse: "reverse (reverse xs) = xs"
  by (induct xs) (simp_all add: reverse_conc)

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>A barebone conversion for discrete summation\<close>

theory Summation_Conversion
imports Factorials Discrete_Summation
begin

text \<open>Extensible theorem collection for solving summation problems\<close>

named_theorems summation "rules for solving summation problems"

declare
  \<Sigma>_const [summation] \<Sigma>_add [summation]
  \<Sigma>_factor [summation] monomial_ffact [summation]

lemma intervall_simps [summation]:
  "(\<Sum>k::nat = 0..0. f k) = f 0"
  "(\<Sum>k::nat = 0..Suc n. f k) = f (Suc n) + (\<Sum>k::nat = 0..n. f k)"
  by (simp_all add: add.commute)

lemma \<Delta>_ffact:
  "\<Delta> (ffact (Suc n)) k = of_nat (Suc n) * ffact n (of_int k :: 'a :: comm_ring_1)"
proof (induct n)
  case 0 then show ?case
    by (simp add: \<Delta>_def ffact_Suc)
next
  case (Suc n)
  obtain m where "m = Suc n" by blast
  have "\<Delta> (ffact (Suc m)) k =
    ffact (Suc m) (of_int (k + 1)) - ffact (Suc m) (of_int k :: 'a)"
    by (simp add: \<Delta>_def)
  also have "\<dots> = of_int (k + 1) * ffact m (of_int k)
    - (ffact m (of_int k) * (of_int k - of_nat m))"
    using ffact_Suc_rev [of m "(of_int k :: 'a :: comm_ring_1)"]
    by (simp add: ac_simps ffact_Suc)
  also have "\<dots> = (of_int k + 1 - of_int k + of_nat m) * ffact m (of_int k)"
    by (simp add: algebra_simps)
  also have "\<dots> = of_nat (Suc m) * ffact m (of_int k)" by simp
  also have "\<dots> = of_nat (Suc m) * ffact (Suc m - 1) (of_int k)" by simp
  finally show ?case by (simp only: \<open>m = Suc n\<close> diff_Suc_1)
qed

lemma \<Sigma>_ffact_divide [summation]:
  "\<Sigma> (ffact n) j l =
    (ffact (Suc n) (of_int l :: 'a :: {idom_divide, semiring_char_0}) - ffact (Suc n) (of_int j)) div of_nat (Suc n)"
proof -
  have *: "(of_nat (Suc n) * \<Sigma> (ffact n) j l) div of_nat (Suc n) = (\<Sigma> (ffact n) j l :: 'a)"
    using of_nat_neq_0 [where ?'a = 'a] by simp
  have "ffact (Suc n) (of_int l :: 'a) - ffact (Suc n) (of_int j) =
    \<Sigma> (\<lambda>k. \<Delta> (ffact (Suc n)) k) j l"
    by (simp add: \<Sigma>_\<Delta>)
  also have "\<dots> = \<Sigma> (\<lambda>k. of_nat (Suc n) * ffact n (of_int k)) j l"
    by (simp add: \<Delta>_ffact)
  also have "\<dots> = of_nat (Suc n) * \<Sigma> (ffact n \<circ> of_int) j l"
    by (simp add: \<Sigma>_factor comp_def)
  finally show ?thesis by (simp only: \<Sigma>_comp_of_int * of_nat_eq_0_iff)
qed

text \<open>Various other rules\<close>

lemma of_int_coeff:
  "(of_int l :: 'a::comm_ring_1) * numeral k = of_int (l * numeral k)"
  by simp

lemmas nat_simps =
  add_0_left add_0_right add_Suc add_Suc_right
  mult_Suc mult_Suc_right mult_zero_left mult_zero_right
  One_nat_def of_nat_simps

lemmas of_int_pull_out =
  of_int_add [symmetric] of_int_diff [symmetric] of_int_mult [symmetric]
  of_int_coeff

lemma of_nat_coeff:
  "(of_nat n :: 'a::comm_semiring_1) * numeral m = of_nat (n * numeral m)"
  by (induct n) simp_all

lemmas of_nat_pull_out =
  of_nat_add [symmetric] of_nat_mult [symmetric] of_nat_coeff

lemmas nat_pull_in =
  nat_int_add

lemmas of_int_pull_in =
  of_int_pull_out [symmetric] add_divide_distrib diff_divide_distrib of_int_power
  of_int_numeral of_int_neg_numeral times_divide_eq_left [symmetric]

text \<open>Special for @{typ nat}\<close>

definition lift_nat :: "(nat \<Rightarrow> nat) \<Rightarrow> int \<Rightarrow> int"
where
  "lift_nat f = int \<circ> f \<circ> nat"

definition \<Sigma>_nat :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" ("\<Sigma>\<^sub>\<nat>")
where
  [summation]: "\<Sigma>\<^sub>\<nat> f m n = nat (\<Sigma> (lift_nat f) (int m) (int n))"

definition pos_id :: "int \<Rightarrow> int"
where
  "pos_id k = (if k < 0 then 0 else k)"

lemma \<Sigma>_pos_id [summation]:
  "0 \<le> k \<Longrightarrow> 0 \<le> l \<Longrightarrow> \<Sigma> (\<lambda>r. f (pos_id r)) k l = \<Sigma> f k l"
  by (simp add: \<Sigma>_def pos_id_def)

lemma [summation]:
  "(0::int) \<le> 0"
  "(0::int) \<le> 1"
  "(0::int) \<le> numeral m"
  "(0::int) \<le> int n"
  by simp_all

lemma [summation]:
  "lift_nat (\<lambda>n. m) = (\<lambda>k. int m)"
  by (simp add: lift_nat_def fun_eq_iff)

lemma [summation]:
  "lift_nat (\<lambda>n. n) = pos_id"
  by (simp add: lift_nat_def fun_eq_iff pos_id_def)

lemma [summation]:
  "lift_nat (\<lambda>n. f n + g n) = (\<lambda>k. lift_nat f k + lift_nat g k)"
  by (simp add: lift_nat_def fun_eq_iff)

lemma [summation]:
  "lift_nat (\<lambda>n. m * f n) = (\<lambda>k. int m * lift_nat f k)"
  by (simp add: lift_nat_def fun_eq_iff)

lemma [summation]:
  "lift_nat (\<lambda>n. f n * m) = (\<lambda>k. lift_nat f k * int m)"
  by (simp add: lift_nat_def fun_eq_iff)

lemma [summation]:
  "lift_nat (\<lambda>n. f n ^ m) = (\<lambda>k. lift_nat f k ^ m)"
  by (simp add: lift_nat_def fun_eq_iff)

text \<open>Generic conversion\<close>

ML \<open>
signature SUMMATION =
sig
  val conv: Proof.context -> conv
end

structure Summation : SUMMATION =
struct

val simps2 = @{thms Stirling.simps ffact_0 ffact_Suc nat_simps};
val simpset3 =
  @{context}
  |> fold Simplifier.add_simp @{thms field_simps}
  |> Simplifier.simpset_of;
val simps4 = @{thms of_int_pull_out of_nat_pull_out nat_pull_in};
val simps6 = @{thms of_int_pull_in};

fun conv ctxt =
  let
    val ctxt1 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp (Named_Theorems.get ctxt @{named_theorems summation})
    val ctxt2 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps2
    val ctxt3 =
      ctxt
      |> put_simpset simpset3
    val ctxt4 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps4
    val semiring_conv_base = Semiring_Normalizer.semiring_normalize_conv ctxt
    val semiring_conv = Conv.arg_conv (Conv.arg1_conv (Conv.arg_conv semiring_conv_base))
      else_conv Conv.arg1_conv (Conv.arg_conv semiring_conv_base)
      else_conv semiring_conv_base
    val ctxt6 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps6
  in
     Simplifier.rewrite ctxt1
     then_conv Simplifier.rewrite ctxt2
     then_conv Simplifier.rewrite ctxt3
     then_conv Simplifier.rewrite ctxt4
     then_conv semiring_conv
     then_conv Simplifier.rewrite ctxt6
  end

end
\<close>

hide_fact (open) nat_simps of_int_pull_out of_int_pull_in

end


subsection \<open>Monotone Convergence \label{sec:monconv}\<close>

theory MonConv
imports Complex_Main
begin

text \<open>A sensible requirement for an integral operator is that it be
  ``well-behaved'' with respect to limit functions. To become just a
  little more
  precise, it is expected that the limit operator may be interchanged
  with the integral operator under conditions that are as weak as
  possible. To this
  end, the notion of monotone convergence is introduced and later
  applied in the definition of the integral.

  In fact, we distinguish three types of monotone convergence here:
  There are converging sequences of real numbers, real functions and
  sets. Monotone convergence could even be defined more generally for
  any type in the axiomatic type class\footnote{For the concept of axiomatic type
  classes, see \<^cite>\<open>"Nipkow93" and "wenzelax"\<close>} \<open>ord\<close> of ordered
  types like this.

  @{prop "mon_conv u f \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and> Sup (range u) = f"}

  However, this employs the general concept of a least upper bound.
  For the special types we have in mind, the more specific
  limit --- respective union --- operators are available, combined with many theorems
  about their properties. For the type of real- (or rather ordered-) valued functions,
  the less-or-equal relation is defined pointwise.

  @{thm le_fun_def [no_vars]}
\<close>

(*monotone convergence*)

text \<open>Now the foundations are laid for the definition of monotone
  convergence. To express the similarity of the different types of
  convergence, a single overloaded operator is used.\<close>

consts
  mon_conv:: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a::ord \<Rightarrow> bool" ("_\<up>_" [60,61] 60)
overloading
  mon_conv_real \<equiv> "mon_conv :: _ \<Rightarrow> real \<Rightarrow> bool"
  mon_conv_real_fun \<equiv> "mon_conv :: _ \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool"
  mon_conv_set \<equiv> "mon_conv :: _ \<Rightarrow> 'a set \<Rightarrow> bool"
begin

definition "x\<up>(y::real) \<equiv> (\<forall>n. x n \<le> x (Suc n)) \<and> x \<longlonglongrightarrow> y"
definition "u\<up>(f::'a \<Rightarrow> real) \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and>  (\<forall>w. (\<lambda>n. u n w) \<longlonglongrightarrow> f w)"
definition "A\<up>(B::'a set) \<equiv> (\<forall>n. A n \<le> A (Suc n)) \<and> B = (\<Union>n. A n)"

end

theorem realfun_mon_conv_iff: "(u\<up>f) = (\<forall>w. (\<lambda>n. u n w)\<up>((f w)::real))"
  by (auto simp add: mon_conv_real_def mon_conv_real_fun_def le_fun_def)

text \<open>The long arrow signifies convergence of real sequences as
  defined in the theory \<open>SEQ\<close> \<^cite>\<open>"Fleuriot:2000:MNR"\<close>. Monotone convergence
  for real functions is simply pointwise monotone convergence.

  Quite a few properties of these definitions will be necessary later,
  and they are listed now, giving only few select proofs.\<close>

    (*This theorem, too, could be proved just the same for any ord
  Type!*)

lemma assumes mon_conv: "x\<up>(y::real)"
  shows mon_conv_mon: "(x i) \<le> (x (m+i))"
(*<*)proof (induct m)
  case 0
  show ?case by simp

next
  case (Suc n)
  also
  from mon_conv have "x (n+i) \<le> x (Suc n+i)"
    by (simp add: mon_conv_real_def)
  finally show ?case .
qed(*>*)

lemma limseq_shift_iff: "(\<lambda>m. x (m+i)) \<longlonglongrightarrow> y = x \<longlonglongrightarrow> y"
(*<*)proof (induct i)
  case 0 show ?case by simp
next
  case (Suc n)
  also have "(\<lambda>m. x (m + n)) \<longlonglongrightarrow> y = (\<lambda>m. x (Suc m + n)) \<longlonglongrightarrow> y"
    by (rule filterlim_sequentially_Suc[THEN sym])
  also have "\<dots> = (\<lambda>m. x (m + Suc n)) \<longlonglongrightarrow> y"
    by simp
  finally show ?case .
qed(*>*)

    (*This, too, could be established in general*)
theorem assumes mon_conv: "x\<up>(y::real)"
  shows real_mon_conv_le: "x i \<le> y"
proof -
  from mon_conv have "(\<lambda>m. x (m+i)) \<longlonglongrightarrow> y"
    by (simp add: mon_conv_real_def limseq_shift_iff)
  also from mon_conv have "\<forall>m\<ge>0. x i \<le> x (m+i)" by (simp add: mon_conv_mon)
  ultimately show ?thesis by (rule LIMSEQ_le_const[OF _ exI[where x=0]])
qed

theorem assumes mon_conv: "x\<up>(y::('a \<Rightarrow> real))"
  shows realfun_mon_conv_le: "x i \<le> y"
proof -
  {fix w
    from mon_conv have "(\<lambda>i. x i w)\<up>(y w)"
      by (simp add: realfun_mon_conv_iff)
    hence "x i w \<le> y w"
      by (rule real_mon_conv_le)
  }
  thus ?thesis by (simp add: le_fun_def)
qed

lemma assumes mon_conv: "x\<up>(y::real)"
  and less: "z < y"
  shows real_mon_conv_outgrow: "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> z < x m"
proof -
  from less have less': "0 < y-z"
    by simp
  have "\<exists>n.\<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z"
  proof -
    from mon_conv have aux: "\<And>r. r > 0 \<Longrightarrow> \<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < r"
    unfolding mon_conv_real_def lim_sequentially dist_real_def by auto
    with less' show "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z" by auto
  qed
  also
  { fix m
    from mon_conv have "x m \<le> y"
      by (rule real_mon_conv_le)
    hence "\<bar>x m - y\<bar> = y - x m"
      by arith
    also assume "\<bar>x m - y\<bar> < y - z"
    ultimately have "z < x m"
      by arith
  }
  ultimately show ?thesis
    by blast
qed

theorem real_mon_conv_times:
  assumes xy: "x\<up>(y::real)" and nn: "0\<le>z"
  shows "(\<lambda>m. z*x m)\<up>(z*y)"
(*<*)proof -
  from assms have "\<And>n. z*x n \<le> z*x (Suc n)"
    by (simp add: mon_conv_real_def mult_left_mono)
  also from xy have "(\<lambda>m. z*x m)\<longlonglongrightarrow>(z*y)"
    by (simp add: mon_conv_real_def tendsto_const tendsto_mult)
  ultimately show ?thesis by (simp add: mon_conv_real_def)
qed(*>*)

theorem realfun_mon_conv_times:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and nn: "0\<le>z"
  shows "(\<lambda>m w. z*x m w)\<up>(\<lambda>w. z*y w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. z*x m w)\<up>(z*y w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_times)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_add:
  assumes xy: "x\<up>(y::real)" and ab: "a\<up>(b::real)"
  shows "(\<lambda>m. x m + a m)\<up>(y + b)"
(*<*)proof -
  { fix n
    from assms have "x n \<le> x (Suc n)" and "a n \<le> a (Suc n)"
      by (simp_all add: mon_conv_real_def)
    hence "x n + a n \<le> x (Suc n) + a (Suc n)"
      by simp
  }
  also from assms have "(\<lambda>m. x m + a m)\<longlonglongrightarrow>(y + b)" by (simp add: mon_conv_real_def tendsto_add)
  ultimately show ?thesis by (simp add: mon_conv_real_def)
qed(*>*)

theorem realfun_mon_conv_add:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and ab: "a\<up>(b::'a \<Rightarrow> real)"
  shows "(\<lambda>m w. x m w + a m w)\<up>(\<lambda>w. y w + b w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. x m w + a m w)\<up>(y w + b w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_add)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
proof -
  from incseq_convergent[of c x] mon bound
  obtain l where "c \<longlonglongrightarrow> l" "\<forall>i. c i \<le> l"
    by (auto simp: incseq_Suc_iff)
  moreover \<comment> \<open>This is like $\isacommand{also}$ but lacks the transitivity step.\<close>
  with bound have "l \<le> x"
    by (intro LIMSEQ_le_const2) auto
  ultimately show ?thesis
    by (auto simp: mon_conv_real_def mon)
qed

theorem real_mon_conv_dom:
  assumes xy: "x\<up>(y::real)" and mon: "\<And>n. c n \<le> c (Suc n)"
  and dom: "c \<le> x"
  shows "\<exists>l. c\<up>l \<and> l\<le>y"
proof -
  from dom have "\<And>n. c n \<le> x n" by (simp add: le_fun_def)
  also from xy have "\<And>n. x n \<le> y" by (simp add: real_mon_conv_le)
  also note mon
  ultimately show ?thesis by (simp add: real_mon_conv_bound)
qed

text\<open>\newpage\<close>
theorem realfun_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::'a \<Rightarrow> real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
(*<*)proof
  define r where "r t = (SOME l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t)" for t
  { fix t
    from mon have m2: "\<And>n. c n t \<le> c (Suc n) t" by (simp add: le_fun_def)
    also
    from bound have "\<And>n. c n t \<le> x t" by (simp add: le_fun_def)

    ultimately have "\<exists>l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t" (is "\<exists>l. ?P l")
      by (rule real_mon_conv_bound)
    hence "?P (SOME l. ?P l)" by (rule someI_ex)
    hence "(\<lambda>n. c n t)\<up>r t \<and> r t\<le>x t" by (simp add: r_def)
  }
  thus "c\<up>r \<and> r \<le> x" by (simp add: realfun_mon_conv_iff le_fun_def)
qed (*>*)

text \<open>This brings the theory to an end. Notice how the definition of the limit of a
  real sequence is visible in the proof to \<open>real_mon_conv_outgrow\<close>, a lemma that will be used for a
  monotonicity proof of the integral of simple functions later on.\<close>(*<*)
  (*Another set construction. Needed in ImportPredSet, but Set is shadowed beyond
  reconstruction there.
  Before making disjoint, we first need an ascending series of sets*)

primrec mk_mon::"(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set"
where
  "mk_mon A 0 = A 0"
| "mk_mon A (Suc n) = A (Suc n) \<union> mk_mon A n"

lemma "mk_mon A \<up> (\<Union>i. A i)"
proof (unfold mon_conv_set_def)
  { fix n
    have "mk_mon A n \<subseteq> mk_mon A (Suc n)"
      by auto
  }
  also
  have "(\<Union>i. mk_mon A i) = (\<Union>i. A i)"
  proof
    { fix i x
      assume "x \<in> mk_mon A i"
      hence "\<exists>j. x \<in> A j"
        by (induct i) auto
      hence "x \<in> (\<Union>i. A i)"
        by simp
    }
    thus "(\<Union>i. mk_mon A i) \<subseteq> (\<Union>i. A i)"
      by auto

    { fix i
      have "A i \<subseteq> mk_mon A i"
        by (induct i) auto
    }
    thus "(\<Union>i. A i) \<subseteq> (\<Union>i. mk_mon A i)"
      by auto
  qed
  ultimately show "(\<forall>n. mk_mon A n \<subseteq> mk_mon A (Suc n)) \<and> \<Union>(A ` UNIV) = (\<Union>n. mk_mon A n)"
    by simp
qed(*>*)

end


(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports ZF
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

consts comb :: i
datatype comb =
  K
| S
| app ("p \<in> comb", "q \<in> comb")  (infixl \<open>\<bullet>\<close> 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

consts contract  :: i
abbreviation contract_syntax :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<^sup>1\<close> 50)
  where "p \<rightarrow>\<^sup>1 q \<equiv> \<langle>p,q\<rangle> \<in> contract"

abbreviation contract_multi :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<close> 50)
  where "p \<rightarrow> q \<equiv> \<langle>p,q\<rangle> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "\<lbrakk>p \<in> comb;  q \<in> comb\<rbrakk> \<Longrightarrow> K\<bullet>p\<bullet>q \<rightarrow>\<^sup>1 p"
    S:   "\<lbrakk>p \<in> comb;  q \<in> comb;  r \<in> comb\<rbrakk> \<Longrightarrow> S\<bullet>p\<bullet>q\<bullet>r \<rightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "\<lbrakk>p\<rightarrow>\<^sup>1q;  r \<in> comb\<rbrakk> \<Longrightarrow> p\<bullet>r \<rightarrow>\<^sup>1 q\<bullet>r"
    Ap2: "\<lbrakk>p\<rightarrow>\<^sup>1q;  r \<in> comb\<rbrakk> \<Longrightarrow> r\<bullet>p \<rightarrow>\<^sup>1 r\<bullet>q"
  type_intros comb.intros

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

consts parcontract :: i

abbreviation parcontract_syntax :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<Rrightarrow>\<^sup>1\<close> 50)
  where "p \<Rrightarrow>\<^sup>1 q \<equiv> \<langle>p,q\<rangle> \<in> parcontract"

abbreviation parcontract_multi :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<Rrightarrow>\<close> 50)
  where "p \<Rrightarrow> q \<equiv> \<langle>p,q\<rangle> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "\<lbrakk>p \<in> comb\<rbrakk> \<Longrightarrow> p \<Rrightarrow>\<^sup>1 p"
    K:    "\<lbrakk>p \<in> comb;  q \<in> comb\<rbrakk> \<Longrightarrow> K\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 p"
    S:    "\<lbrakk>p \<in> comb;  q \<in> comb;  r \<in> comb\<rbrakk> \<Longrightarrow> S\<bullet>p\<bullet>q\<bullet>r \<Rrightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "\<lbrakk>p\<Rrightarrow>\<^sup>1q;  r\<Rrightarrow>\<^sup>1s\<rbrakk> \<Longrightarrow> p\<bullet>r \<Rrightarrow>\<^sup>1 q\<bullet>s"
  type_intros comb.intros

text \<open>
  Misc definitions.
\<close>

definition I :: i
  where "I \<equiv> S\<bullet>K\<bullet>K"

definition diamond :: "i \<Rightarrow> o"
  where "diamond(r) \<equiv>
    \<forall>x y. \<langle>x,y\<rangle>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. \<langle>y,z\<rangle>\<in>r \<and> <y',z> \<in> r))"

subsection \<open>Transitive closure preserves the Church-Rosser property\<close>

lemma diamond_strip_lemmaD [rule_format]:
  "\<lbrakk>diamond(r);  \<langle>x,y\<rangle>:r^+\<rbrakk> \<Longrightarrow>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ \<and> \<langle>y,z\<rangle>: r)"
    unfolding diamond_def
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) \<Longrightarrow> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection \<open>Results about Contraction\<close>

text \<open>
  For type checking: replaces \<^term>\<open>a \<rightarrow>\<^sup>1 b\<close> by \<open>a, b \<in>
  comb\<close>.
\<close>

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb \<Longrightarrow> I\<bullet>p \<rightarrow> p"
  \<comment> \<open>Example only: not used\<close>
  unfolding I_def by (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  unfolding I_def by blast

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

lemma I_contract_E: "I \<rightarrow>\<^sup>1 r \<Longrightarrow> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p \<rightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>q. r = K\<bullet>q \<and> p \<rightarrow>\<^sup>1 q)"
  by auto

lemma Ap_reduce1: "\<lbrakk>p \<rightarrow> q;  r \<in> comb\<rbrakk> \<Longrightarrow> p\<bullet>r \<rightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "\<lbrakk>p \<rightarrow> q;  r \<in> comb\<rbrakk> \<Longrightarrow> r\<bullet>p \<rightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text \<open>Counterexample to the diamond property for \<open>\<rightarrow>\<^sup>1\<close>.\<close>

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
    unfolding diamond_def
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection \<open>Results about Parallel Contraction\<close>

text \<open>For type checking: replaces \<open>a \<Rrightarrow>\<^sup>1 b\<close> by \<open>a, b
  \<in> comb\<close>\<close>
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text \<open>Derive a case for each combinator constructor.\<close>
inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]:
    "K\<bullet>p \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p'. r = K\<bullet>p' \<and> p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p'. r = S\<bullet>p' \<and> p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' \<and> p \<Rrightarrow>\<^sup>1 p' \<and> q \<Rrightarrow>\<^sup>1 q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  \<comment> \<open>Church-Rosser property for parallel contraction\<close>
    unfolding diamond_def
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text \<open>
  \medskip Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.
\<close>

lemma contract_imp_parcontract: "p\<rightarrow>\<^sup>1q \<Longrightarrow> p\<Rrightarrow>\<^sup>1q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p\<rightarrow>q \<Longrightarrow> p\<Rrightarrow>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p\<Rrightarrow>\<^sup>1q \<Longrightarrow> p\<rightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p\<Rrightarrow>q \<Longrightarrow> p\<rightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p\<Rrightarrow>q \<longleftrightarrow> p\<rightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end


(*  Title:      HOL/HOLCF/Library/List_Cpo.thy
    Author:     Brian Huffman
*)

section {* Lists as a complete partial order *}

theory List_Cpo
imports HOLCF
begin

subsection {* Lists are a partial order *}

instantiation list :: (po) po
begin

definition
  "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"

instance proof
  fix xs :: "'a list"
  from below_refl show "xs \<sqsubseteq> xs"
    unfolding below_list_def
    by (rule list_all2_refl)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
  with below_trans show "xs \<sqsubseteq> zs"
    unfolding below_list_def
    by (rule list_all2_trans)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
  with below_antisym show "xs = ys"
    unfolding below_list_def
    by (rule list_all2_antisym)
qed

end

lemma below_list_simps [simp]:
  "[] \<sqsubseteq> []"
  "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
  "\<not> [] \<sqsubseteq> y # ys"
  "\<not> x # xs \<sqsubseteq> []"
by (simp_all add: below_list_def)

lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma list_below_induct [consumes 1, case_names Nil Cons]:
  assumes "xs \<sqsubseteq> ys"
  assumes 1: "P [] []"
  assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
  shows "P xs ys"
using `xs \<sqsubseteq> ys`
proof (induct xs arbitrary: ys)
  case Nil thus ?case by (simp add: 1)
next
  case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
qed

lemma list_below_cases:
  assumes "xs \<sqsubseteq> ys"
  obtains "xs = []" and "ys = []" |
    x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
using assms by (cases xs, simp, cases ys, auto)

text "Thanks to Joachim Breitner"

lemma list_Cons_below:
  assumes "a # as \<sqsubseteq> xs"
  obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
  using assms by (cases xs, auto)

lemma list_below_Cons:
  assumes "xs \<sqsubseteq> b # bs"
  obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
  using assms by (cases xs, auto)

lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
by (cases xs, simp, cases ys, simp, simp)

lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
by (cases xs, simp, cases ys, simp, simp)

lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
by (rule chainI, rule hd_mono, erule chainE)

lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
by (rule chainI, rule tl_mono, erule chainE)

lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
unfolding below_list_def by (rule list_all2_lengthD)

lemma list_chain_induct [consumes 1, case_names Nil Cons]:
  assumes "chain S"
  assumes 1: "P (\<lambda>i. [])"
  assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
  shows "P S"
using `chain S`
proof (induct "S 0" arbitrary: S)
  case Nil
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
  with Nil have "\<forall>i. S i = []" by simp
  thus ?case by (simp add: 1)
next
  case (Cons x xs)
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF `chain S`])
  hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
  have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
    using `chain S` by simp_all
  moreover have "P (\<lambda>i. tl (S i))"
    using `chain S` and `x # xs = S 0` [symmetric]
    by (simp add: Cons(1))
  ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
    by (rule 2)
  thus "P S" by (simp add: *)
qed

lemma list_chain_cases:
  assumes S: "chain S"
  obtains "S = (\<lambda>i. [])" |
    A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
using S by (induct rule: list_chain_induct) simp_all

subsection {* Lists are a complete partial order *}

lemma is_lub_Cons:
  assumes A: "range A <<| x"
  assumes B: "range B <<| xs"
  shows "range (\<lambda>i. A i # B i) <<| x # xs"
using assms
unfolding is_lub_def is_ub_def
by (clarsimp, case_tac u, simp_all)

instance list :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a list"
  assume "chain S" thus "\<exists>x. range S <<| x"
  proof (induct rule: list_chain_induct)
    case Nil thus ?case by (auto intro: is_lub_const)
  next
    case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
  qed
qed

subsection {* Continuity of list operations *}

lemma cont2cont_Cons [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x # g x)"
apply (rule contI)
apply (rule is_lub_Cons)
apply (erule contE [OF f])
apply (erule contE [OF g])
done

lemma lub_Cons:
  fixes A :: "nat \<Rightarrow> 'a::cpo"
  assumes A: "chain A" and B: "chain B"
  shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
by (intro lub_eqI is_lub_Cons cpo_lubI A B)

lemma cont2cont_case_list:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
  assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
  assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
apply (rule cont_apply [OF f])
apply (rule contI)
apply (erule list_chain_cases)
apply (simp add: is_lub_const)
apply (simp add: lub_Cons)
apply (simp add: cont2contlubE [OF h2])
apply (simp add: cont2contlubE [OF h3])
apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
apply (rule cpo_lubI, rule chainI, rule below_trans)
apply (erule cont2monofunE [OF h2 chainE])
apply (erule cont2monofunE [OF h3 chainE])
apply (case_tac y, simp_all add: g h1)
done

lemma cont2cont_case_list' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
using assms by (simp add: cont2cont_case_list prod_cont_iff)

text {* The simple version (due to Joachim Breitner) is needed if the
  element type of the list is not a cpo. *}

lemma cont2cont_case_list_simple [simp, cont2cont]:
  assumes "cont (\<lambda>x. f1 x)"
  assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
  shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
using assms by (cases l) auto

text {* Lemma for proving continuity of recursive list functions: *}

lemma list_contI:
  fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
  assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
  assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
  assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
  assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
  shows "cont f"
proof (rule contI2)
  obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
  proof
    fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
    by (simp add: cont2cont_LAM g1 g2 g3)
  qed
  show mono: "monofun f"
    apply (rule monofunI)
    apply (erule list_below_induct)
    apply simp
    apply (simp add: f h monofun_cfun)
    done
  fix Y :: "nat \<Rightarrow> 'a list"
  assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
    apply (induct rule: list_chain_induct)
    apply simp
    apply (simp add: lub_Cons f h)
    apply (simp add: lub_APP ch2ch_monofun [OF mono])
    apply (simp add: monofun_cfun)
    done
qed

text {* Continuity rule for map *}

lemma cont2cont_map [simp, cont2cont]:
  assumes f: "cont (\<lambda>(x, y). f x y)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. map (\<lambda>y. f x y) (g x))"
using f
apply (simp add: prod_cont_iff)
apply (rule cont_apply [OF g])
apply (rule list_contI, rule list.map, simp, simp, simp)
apply (induct_tac y, simp, simp)
done

text {* There are probably lots of other list operations that also
deserve to have continuity lemmas.  I'll add more as they are
needed. *}

subsection {* Lists are a discrete cpo *}

instance list :: (discrete_cpo) discrete_cpo
proof
  fix xs ys :: "'a list"
  show "xs \<sqsubseteq> ys \<longleftrightarrow> xs = ys"
    by (induct xs arbitrary: ys, case_tac [!] ys, simp_all)
qed

subsection {* Compactness and chain-finiteness *}

lemma compact_Nil [simp]: "compact []"
apply (rule compactI2)
apply (erule list_chain_cases)
apply simp
apply (simp add: lub_Cons)
done

lemma compact_Cons: "\<lbrakk>compact x; compact xs\<rbrakk> \<Longrightarrow> compact (x # xs)"
apply (rule compactI2)
apply (erule list_chain_cases)
apply (auto simp add: lub_Cons dest!: compactD2)
apply (rename_tac i j, rule_tac x="max i j" in exI)
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded1]])
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded2]])
apply (erule (1) conjI)
done

lemma compact_Cons_iff [simp]:
  "compact (x # xs) \<longleftrightarrow> compact x \<and> compact xs"
apply (safe intro!: compact_Cons)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>x. x # xs)")
apply (drule (1) adm_subst, simp, simp)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>xs. x # xs)")
apply (drule (1) adm_subst, simp, simp)
done

instance list :: (chfin) chfin
proof
  fix Y :: "nat \<Rightarrow> 'a list" assume "chain Y"
  moreover have "\<And>(xs::'a list). compact xs"
    by (induct_tac xs, simp_all)
  ultimately show "\<exists>i. max_in_chain i Y"
    by (rule compact_imp_max_in_chain)
qed

subsection {* Using lists with fixrec *}

definition
  match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
where
  "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"

definition
  match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
where
  "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"

lemma match_Nil_simps [simp]:
  "match_Nil\<cdot>[]\<cdot>k = k"
  "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
unfolding match_Nil_def by simp_all

lemma match_Cons_simps [simp]:
  "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
  "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
unfolding match_Cons_def by simp_all

setup {*
  Fixrec.add_matchers
    [ (@{const_name Nil}, @{const_name match_Nil}),
      (@{const_name Cons}, @{const_name match_Cons}) ]
*}

end


theory T177
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*  Title:      HOL/ex/Sqrt_Script.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>Square roots of primes are irrational (script version)\<close>

theory Sqrt_Script
imports Complex_Main "HOL-Computational_Algebra.Primes"
begin

text \<open>
  \medskip Contrast this linear Isabelle/Isar script with Markus
  Wenzel's more mathematical version.
\<close>

subsection \<open>Preliminaries\<close>

lemma prime_nonzero:  "prime (p::nat) \<Longrightarrow> p \<noteq> 0"
  by (force simp add: prime_nat_iff)

lemma prime_dvd_other_side:
    "(n::nat) * n = p * (k * k) \<Longrightarrow> prime p \<Longrightarrow> p dvd n"
  apply (subgoal_tac "p dvd n * n", blast dest: prime_dvd_mult_nat)
  apply auto
  done

lemma reduction: "prime (p::nat) \<Longrightarrow>
    0 < k \<Longrightarrow> k * k = p * (j * j) \<Longrightarrow> k < p * j \<and> 0 < j"
  apply (rule ccontr)
  apply (simp add: linorder_not_less)
  apply (erule disjE)
   apply (frule mult_le_mono, assumption)
   apply auto
  apply (force simp add: prime_nat_iff)
  done

lemma rearrange: "(j::nat) * (p * j) = k * k \<Longrightarrow> k * k = p * (j * j)"
  by (simp add: ac_simps)

lemma prime_not_square:
    "prime (p::nat) \<Longrightarrow> (\<And>k. 0 < k \<Longrightarrow> m * m \<noteq> p * (k * k))"
  apply (induct m rule: nat_less_induct)
  apply clarify
  apply (frule prime_dvd_other_side, assumption)
  apply (erule dvdE)
  apply (simp add: nat_mult_eq_cancel_disj prime_nonzero)
  apply (blast dest: rearrange reduction)
  done

subsection \<open>Main theorem\<close>

text \<open>
  The square root of any prime number (including \<open>2\<close>) is
  irrational.
\<close>

theorem prime_sqrt_irrational:
    "prime (p::nat) \<Longrightarrow> x * x = real p \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<notin> \<rat>"
  apply (rule notI)
  apply (erule Rats_abs_nat_div_natE)
  apply (simp del: of_nat_mult
              add: abs_if divide_eq_eq prime_not_square of_nat_mult [symmetric])
  done

lemmas two_sqrt_irrational =
  prime_sqrt_irrational [OF two_is_prime_nat]

end


theory Conntrack_State
imports "../Common/Negation_Type" "../../Simple_Firewall/Common/Lib_Enum_toString"
begin

datatype ctstate = CT_New | CT_Established | CT_Related | CT_Untracked | CT_Invalid

text\<open>The state associated with a packet can be added as a tag to the packet.
      See @{file "../Semantics_Stateful.thy"}.\<close>

fun match_ctstate :: "ctstate set \<Rightarrow> ctstate \<Rightarrow> bool" where
"match_ctstate S s_tag \<longleftrightarrow> s_tag \<in> S"

fun ctstate_conjunct :: "ctstate set \<Rightarrow> ctstate set \<Rightarrow> ctstate set option" where
  "ctstate_conjunct S1 S2 = (if S1 \<inter> S2 = {} then None else Some (S1 \<inter> S2))"

value[code] "ctstate_conjunct {CT_Established, CT_New} {CT_New}"

lemma ctstate_conjunct_correct: "match_ctstate S1 pkt \<and> match_ctstate S2 pkt \<longleftrightarrow>
  (case ctstate_conjunct S1 S2 of None \<Rightarrow> False | Some S' \<Rightarrow> match_ctstate S' pkt)"
  apply simp
  by blast

lemma UNIV_ctstate: "UNIV = {CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid}" using ctstate.exhaust by auto

(*
function ctstate_set_toString_list :: "ctstate set \<Rightarrow> string list" where
  "ctstate_set_toString_list S = (if S = {} then [] else
    if CT_New \<in> S then ''NEW''#ctstate_set_toString_list (S - {CT_New}) else
    if CT_Established \<in> S then ''ESTABLISHED''#ctstate_set_toString_list (S - {CT_Established}) else
    if CT_Related \<in> S then ''RELATED''#ctstate_set_toString_list (S - {CT_Related}) else
    if CT_Untracked \<in> S then ''UNTRACKED''#ctstate_set_toString_list (S - {CT_Untracked}) else [''ERROR-unkown-ctstate''])"
by(pat_completeness) auto

termination ctstate_set_toString_list
  apply(relation "measure (\<lambda>(S). card S)")
  apply(simp_all add: card_gt_0_iff)
  done

*)
instance ctstate :: finite
proof
  from UNIV_ctstate show "finite (UNIV:: ctstate set)" using finite.simps by auto
qed

lemma "finite (S :: ctstate set)" by simp

instantiation "ctstate" :: enum
begin
  definition "enum_ctstate = [CT_New, CT_Established, CT_Related, CT_Untracked, CT_Invalid]"

  definition "enum_all_ctstate P \<longleftrightarrow> P CT_New \<and> P CT_Established \<and> P CT_Related \<and> P CT_Untracked \<and> P CT_Invalid"

  definition "enum_ex_ctstate P \<longleftrightarrow> P CT_New \<or> P CT_Established \<or> P CT_Related \<or> P CT_Untracked \<or> P CT_Invalid"
instance proof
  show "UNIV = set (enum_class.enum :: ctstate list)"
    by(simp add: UNIV_ctstate enum_ctstate_def)
  next
  show "distinct (enum_class.enum :: ctstate list)"
    by(simp add: enum_ctstate_def)
  next
  show "\<And>P. (enum_class.enum_all :: (ctstate \<Rightarrow> bool) \<Rightarrow> bool) P = Ball UNIV P"
    by(simp add: UNIV_ctstate enum_all_ctstate_def)
  next
  show "\<And>P. (enum_class.enum_ex :: (ctstate \<Rightarrow> bool) \<Rightarrow> bool) P = Bex UNIV P"
    by(simp add: UNIV_ctstate enum_ex_ctstate_def)
qed
end

definition ctstate_is_UNIV :: "ctstate set \<Rightarrow> bool" where
  "ctstate_is_UNIV c \<equiv> CT_New \<in> c \<and> CT_Established \<in> c \<and> CT_Related \<in> c \<and> CT_Untracked \<in> c \<and> CT_Invalid \<in> c"

lemma ctstate_is_UNIV: "ctstate_is_UNIV c \<longleftrightarrow> c = UNIV"
  unfolding ctstate_is_UNIV_def
  apply(simp add: UNIV_ctstate)
  apply(rule iffI)
  apply(clarify)
   using UNIV_ctstate apply fastforce
   apply(simp)
  done

value[code] "ctstate_is_UNIV {CT_Established}"

fun ctstate_toString :: "ctstate \<Rightarrow> string" where
  "ctstate_toString CT_New = ''NEW''" |
  "ctstate_toString CT_Established = ''ESTABLISHED''" |
  "ctstate_toString CT_Related = ''RELATED''" |
  "ctstate_toString CT_Untracked = ''UNTRACKED''" |
  "ctstate_toString CT_Invalid = ''INVALID''"

definition ctstate_set_toString :: "ctstate set \<Rightarrow> string" where
  "ctstate_set_toString S = list_separated_toString '','' ctstate_toString (enum_set_to_list S)"

lemma "ctstate_set_toString {CT_New, CT_New, CT_Established} = ''NEW,ESTABLISHED''" by eval

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_NStoogeSort2Permutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (nstoogesort2 xs) xs"
  oops

end


theory T122
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory T151
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory sort_MSortTDPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun msorttd :: "int list => int list" where
"msorttd (Nil2) = Nil2"
| "msorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "msorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (msorttd
          (ztake
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2) (Cons2 y (Cons2 x2 x3))))
       (msorttd
          (zdrop
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2)
             (Cons2 y (Cons2 x2 x3))))"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster ztake
          zlength
          zdrop
          or2
          null
          lmerge
          msorttd
          elem
          delete
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (msorttd x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


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

section {* Implementation of natural numbers as binary numerals *}

theory Code_Binary_Nat
imports Code_Abstract_Nat
begin

text {*
  When generating code for functions on natural numbers, the
  canonical representation using @{term "0::nat"} and
  @{term Suc} 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.
*}

subsection {* Representation *}

code_datatype "0::nat" nat_of_num

lemma [code]:
  "(1\<Colon>nat) = Numeral1"
  by simp

lemma [code_abbrev]: "Numeral1 = (1\<Colon>nat)"
  by simp

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

subsection {* Basic arithmetic *}

lemma [code, code del]:
  "(plus :: nat \<Rightarrow> _) = plus" ..

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 {* Bounded subtraction needs some auxiliary *}

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)

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

lemma [code, code del]:
  "(minus :: nat \<Rightarrow> _) = minus" ..

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)

lemma [code, code del]:
  "(times :: nat \<Rightarrow> _) = times" ..

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)

lemma [code, code del]:
  "(HOL.equal :: nat \<Rightarrow> _) = HOL.equal" ..

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)

lemma [code, code del]:
  "(less_eq :: nat \<Rightarrow> _) = less_eq" ..

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)

lemma [code, code del]:
  "(less :: nat \<Rightarrow> _) = less" ..

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)

lemma [code, code del]:
  "divmod_nat = divmod_nat" ..

lemma divmod_nat_code [code]:
  "divmod_nat (nat_of_num k) (nat_of_num l) = divmod k l"
  "divmod_nat m 0 = (0, m)"
  "divmod_nat 0 n = (0, 0)"
  by (simp_all add: prod_eq_iff nat_of_num_numeral del: div_nat_numeral mod_nat_numeral)

subsection {* Conversions *}

lemma [code, code del]:
  "of_nat = 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

hide_const (open) dup sub

end